mirror of
https://github.com/mozilla/gecko-dev.git
synced 2024-11-07 12:15:51 +00:00
233 lines
6.8 KiB
EmacsLisp
233 lines
6.8 KiB
EmacsLisp
;;; -*- Mode: Emacs-Lisp -*-
|
|
;;;
|
|
;;; The contents of this file are subject to the Mozilla Public License
|
|
;;; Version 1.0 (the "License"); you may not use this file except in
|
|
;;; compliance with the License. You may obtain a copy of the License at
|
|
;;; http://www.mozilla.org/MPL/
|
|
;;;
|
|
;;; Software distributed under the License is distributed on an "AS IS"
|
|
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
|
|
;;; the License for the specific language governing rights and limitations
|
|
;;; under the License.
|
|
;;;
|
|
;;; The Original Code is the Grendel mail/news client.
|
|
;;;
|
|
;;; The Initial Developer of the Original Code is Netscape Communications
|
|
;;; Corporation. Portions created by Netscape are Copyright (C) 1997
|
|
;;; Netscape Communications Corporation. All Rights Reserved.
|
|
;;;
|
|
;;; Created: 25-Sep-97 by Jamie Zawinski <jwz@netscape.com>.
|
|
|
|
|
|
(defun map-folder (file function)
|
|
(cond ((file-directory-p file)
|
|
(message "Listing %s..." file)
|
|
(let* ((default-directory (expand-file-name file))
|
|
(files (directory-files "." nil)))
|
|
(while files
|
|
(or (string-match "\\`\\.\\|\\.summary\\'" (car files))
|
|
(map-folder (car files) function))
|
|
(setq files (cdr files)))))
|
|
(t
|
|
(message "%s (loading)..." file)
|
|
(let ((b (find-file-noselect file)))
|
|
(save-excursion
|
|
(set-buffer b)
|
|
(goto-char (point-min))
|
|
(if (looking-at "\n*From ")
|
|
(funcall function)))
|
|
(kill-buffer b))
|
|
(message "%s ...done." file)))
|
|
nil)
|
|
|
|
(defun map-messages (function)
|
|
(goto-char (point-min))
|
|
(let (start header-end end)
|
|
(while (not (eobp))
|
|
(forward-line 1)
|
|
(setq start (point))
|
|
(let ((case-fold-search nil))
|
|
(if (search-forward "\nFrom " nil t)
|
|
(beginning-of-line)
|
|
(goto-char (point-max))))
|
|
(setq end (point))
|
|
(goto-char start)
|
|
(if (search-forward "\n\n" nil t)
|
|
(forward-char -1)
|
|
(goto-char end))
|
|
(setq header-end (point))
|
|
(funcall function start header-end end)
|
|
(goto-char end)))
|
|
nil)
|
|
|
|
(defun get-header (field &optional limit)
|
|
(let ((case-fold-search t))
|
|
(save-excursion
|
|
(if (re-search-forward (concat "^" field ":[ \t]*") limit t)
|
|
(let ((start (point)))
|
|
(end-of-line)
|
|
(while (looking-at "\n[ \t]")
|
|
(forward-line 1)
|
|
(end-of-line))
|
|
(buffer-substring start (point)))))))
|
|
|
|
|
|
(require 'mail-extr)
|
|
(defun strip-address (addr)
|
|
(let ((fn (symbol-function 'mail-extr-voodoo)))
|
|
(unwind-protect
|
|
(progn
|
|
(fset 'mail-extr-voodoo #'(lambda (x y z) nil))
|
|
(let ((result (mail-extract-address-components addr)))
|
|
(or (car result) (nth 1 result) "")))
|
|
(fset 'mail-extr-voodoo fn))))
|
|
|
|
(defun strip-subject (subj)
|
|
(let ((case-fold-search t))
|
|
(while (or (string-match "\\`re:[ \t]*" subj)
|
|
(string-match "\\`re\\[[0-9]+\\]:[ \t]*" subj))
|
|
(setq subj (substring subj (match-end 0)))))
|
|
subj)
|
|
|
|
(defun parse-refs (refs)
|
|
(let ((result nil)
|
|
(start 0))
|
|
(while (string-match "<[^<>]+>" refs start)
|
|
(setq result (cons (match-string 0 refs) result)
|
|
start (match-end 0)))
|
|
result))
|
|
|
|
|
|
(defun table-count (table)
|
|
(let ((i 0.0))
|
|
(mapatoms #'(lambda (x) (setq i (1+ i))) table)
|
|
i))
|
|
|
|
(defun table-bytes (table)
|
|
(let ((i 0.0))
|
|
(mapatoms #'(lambda (x) (setq i (+ i 1 (length (symbol-name x))))) table)
|
|
i))
|
|
|
|
(defvar total-messages)
|
|
(defvar total-size)
|
|
(defvar author-table)
|
|
(defvar recipient-table)
|
|
(defvar id-table)
|
|
(defvar refs-table)
|
|
(defvar all-ids-table)
|
|
(defvar subject-table)
|
|
(defvar simple-subject-table)
|
|
(defvar all-strings-table)
|
|
(defvar re-count)
|
|
(defvar refs-count)
|
|
|
|
(defun reset ()
|
|
(setq total-messages 0.0
|
|
total-size 0.0
|
|
author-table (make-vector 511 0)
|
|
recipient-table (make-vector 511 0)
|
|
id-table (make-vector 511 0)
|
|
refs-table (make-vector 511 0)
|
|
all-ids-table (make-vector 511 0)
|
|
all-strings-table (make-vector 511 0)
|
|
subject-table (make-vector 511 0)
|
|
simple-subject-table (make-vector 511 0)
|
|
refs-count 0.0
|
|
re-count 0.0))
|
|
|
|
(defun collect-stats ()
|
|
(list
|
|
'messages total-messages
|
|
'size total-size
|
|
'authors (table-count author-table)
|
|
'authors-bytes (table-bytes author-table)
|
|
'recipients (table-count recipient-table)
|
|
'recipients-bytes (table-bytes recipient-table)
|
|
'ids (table-count id-table)
|
|
'ids-bytes (table-bytes id-table)
|
|
'refs (table-count refs-table)
|
|
'refs-bytes (table-bytes refs-table)
|
|
'all-strings (table-count all-strings-table)
|
|
'all-strings-bytes (table-bytes all-strings-table)
|
|
'all-ids (table-count all-ids-table)
|
|
'all-ids-bytes (table-bytes all-ids-table)
|
|
'subjects (table-count subject-table)
|
|
'subjects-bytes (table-bytes subject-table)
|
|
'subjects2 (table-count simple-subject-table)
|
|
'subjects2-bytes (table-bytes simple-subject-table)
|
|
're re-count
|
|
'refs refs-count
|
|
))
|
|
|
|
(defun message-stats (start header-end end)
|
|
(goto-char start)
|
|
(setq total-messages (1+ total-messages)
|
|
total-size (+ total-size (- end start)))
|
|
(if (= 0 (% (floor total-messages) 50))
|
|
(message "%s (%d%%)..." (buffer-name)
|
|
(/ (* 100.0 total-size) (buffer-size))))
|
|
(let* (
|
|
(author (strip-address (or (get-header "from" header-end)
|
|
(get-header "sender" header-end)
|
|
"")))
|
|
(recip (strip-address (or (get-header "to" header-end)
|
|
(get-header "cc" header-end)
|
|
(get-header "newsgroups" header-end)
|
|
"")))
|
|
(id (or (get-header "message-id" header-end)
|
|
""))
|
|
(refs (parse-refs (or (get-header "references" header-end)
|
|
(get-header "in-reply-to" header-end)
|
|
"")))
|
|
(subj (or (get-header "subject" header-end)
|
|
""))
|
|
(subj2 (strip-subject subj))
|
|
)
|
|
(intern author author-table)
|
|
(intern author all-strings-table)
|
|
(intern recip recipient-table)
|
|
(intern recip all-strings-table)
|
|
(intern id id-table)
|
|
(intern id all-ids-table)
|
|
(intern id all-strings-table)
|
|
(intern subj subject-table)
|
|
(intern subj2 simple-subject-table)
|
|
(intern subj2 all-strings-table)
|
|
(if (not (equal subj subj2))
|
|
(setq re-count (1+ re-count)))
|
|
(setq refs-count (+ refs-count (length refs)))
|
|
(while refs
|
|
(intern (car refs) refs-table)
|
|
(intern (car refs) all-ids-table)
|
|
(intern (car refs) all-strings-table)
|
|
(setq refs (cdr refs)))
|
|
))
|
|
|
|
(defun merge-stats (total s)
|
|
(let ((r1 (cdr total))
|
|
(r2 (cdr s)))
|
|
(while r1
|
|
(setcar r1 (+ (car r1) (car r2)))
|
|
(setq r1 (cdr (cdr r1))
|
|
r2 (cdr (cdr r2))))))
|
|
|
|
(defvar all-stats nil)
|
|
|
|
(defun folder-stats (directory)
|
|
(setq all-stats nil)
|
|
(reset)
|
|
(map-folder directory
|
|
#'(lambda ()
|
|
(message "%s..." (buffer-name))
|
|
(map-messages 'message-stats)
|
|
(let ((s (cons (buffer-name) (collect-stats))))
|
|
(cond (all-stats
|
|
(setcdr all-stats (cons s (cdr all-stats)))
|
|
(merge-stats (cdr (car all-stats)) (cdr s)))
|
|
(t (setq all-stats
|
|
(list (cons nil (copy-list (cdr s)))
|
|
s)))))
|
|
(reset)
|
|
))
|
|
all-stats)
|