;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*- ;;; ;;; Touched: Sun Jan 14 01:42:37 2007 -0700 ;;; Time-stamp: <07/03/24 08:20:14 madhu> ;;; Bugs-To: ;;; Copyright (C) 2007 Madhu. All Rights Reserved. ;;; Status: Experimental. Do Not Redistribute. ;;; ;;; $Id: tripwire.lisp,v 1.1 2007/01/15 02:21:08 madhu Exp madhu $ ;;; (defpackage "TRIPWIRE-IMPL-1" (:use "CL") (:export)) (in-package "TRIPWIRE-IMPL-1") ;;; ;;; SUPPORT A FLAT TWDB-FILE-FORMAT-1 (FOR C) ;;; (defgeneric write-database-file-1 (files stream) (:documentation "Write TWDB-FILE-FORMAT-1 to STREAM.")) (defmethod write-database-file-1 ((root-directory pathname) (stream stream)) "Internal. Recursively descend ROOT-DIRECTORY and write entries in TWDB-FILE-FORMAT-1 to STREAM." (let ((root (truename root-directory)) (USER::*DIRED-TRUENAMEP* NIL) (USER::*DIRED-FOLLOW-LINKS* NIL)) (format stream ";;; BEGIN TWDB-FILE-FORMAT-1~T~D~T~A~&" (get-universal-time) (namestring root)) (flet ((dump-entry (path depth directory-p) (declare (ignorable depth directory-p)) (write-string (enough-namestring path root) stream) (write-char #\Tab stream) (USER::stat2 path (loop for (x . rest) on USER::+STATBUF+ do (write (symbol-value x) :stream stream) (write-char (if rest #\Tab #\Newline) stream))))) (with-standard-io-syntax (USER::dired root #'dump-entry))) (format stream ";;; END TWDB-FILE-FORMAT-1 ~D~&" (get-universal-time)))) ;;; ;;; READING TWDB-FILE-FORMAT-1 ;;; (defun parse-header-line-1 (line) "Internal. Return as values the ROOT-NAMESTRING and START-WRITE-TIME." (assert (> (length line) 30) nil 'parse-error) (assert (string= ";;; BEGIN TWDB-FILE-FORMAT-1 " line :end2 29) nil 'parse-error) (let ((pos (position #\Space line :start 29))) (assert pos nil 'parse-error) (multiple-value-bind (file-write-start-time end) (parse-integer line :start 29 :end pos) (assert (= pos end)) (assert (> (length line) pos) nil 'parse-error) (values (subseq line (1+ pos)) file-write-start-time)))) (defvar +statbuf-reverse+ (reverse USER::+STATBUF+) "Internal.") (defun parse-stat-properties-1 (line) "Internal. Returns as values STAT-PROPERTIES and the uppper bounding index of the namestring in LINE. STAT-PROPERTIES is a list of values corresponding to the properties named in USER::+STATBUF+." (let (stat-properties) (loop for sym in +statbuf-reverse+ for end = (length line) then begin for begin = (position #\Tab line :end end :from-end t) do (assert begin nil 'parse-error) (assert (< 0 begin end) nil 'parse-error) (multiple-value-bind (val pos) (parse-integer line :start (1+ begin) :end end) (assert (= pos end) nil 'parse-error) (setf stat-properties (cons val stat-properties) #+NIL(cons sym (cons val stat-properties)))) finally (return (values stat-properties begin))))) ;;; ;;; (defvar *strings-trie* (TRIE:MAKE-TRIE) "Internal. A trie to intern EQ strings.") (defun stat-properties-mode (stat-properties) "Internal." (nth 2 #+NIL(position 'user::mode user::+statbuf+) stat-properties) #+NIL(getf stat-properties 'USER::MODE)) (defun directory-p (stat-properties) "Internal." (= (logand #o170000 (STAT-PROPERTIES-MODE stat-properties)) #o0040000)) (defun symbolic-link-p (stat-properties) "Internal." (= (logand #o170000 (STAT-PROPERTIES-MODE stat-properties)) #o0120000)) (defun regular-file-p (stat-properties) "Internal." (= (logand #o170000 (STAT-PROPERTIES-MODE stat-properties)) #o0100000)) ;;; Our basic datastructure is a FILESET-TRIE which holds STAT(2) ;;; information for a set of files. (defun fileset-trie-add (fileset-trie string &optional stat-properties &key (start 0) end (strings-trie *strings-trie*)) "Internal. STRING holds a / separated pathname." (assert (stat-properties-mode stat-properties)) (loop with last-position = (or end (length string)) for begin = start then (1+ pos) for pos = (position #\/ string :start begin :end last-position) ;XXX for sub-key = (TRIE:INTERN-STRING string :start begin :end (or pos last-position) :strings-trie strings-trie) for x = (assert sub-key) for trie = fileset-trie then sub-trie for sub-trie = (trie::trie-descend trie sub-key) if (endp sub-trie) do (push (cons sub-key (setq sub-trie (cons nil nil))) (cdr trie)) while pos if (= (1+ pos) last-position) do (assert (directory-p stat-properties) nil "Expected a directory.") (loop-finish) finally (setf (car sub-trie) stat-properties))) (defun parse-footer-line-1 (line) "Internal. First value is the FILE-WRITE-END-TIME." (assert (> (length line) 28) nil 'parse-error) (assert (string= ";;; END TWDB-FILE-FORMAT-1 " line :end2 27) nil 'parse-error) (multiple-value-bind (file-write-end-time pos) (parse-integer line :start 27) (values file-write-end-time pos))) (defun read-database-file-1 (stream &key (strings-trie *strings-trie*)) "Internal. Returns a FILESET-TRIE object from. Reads STREAM which should contain data in TWDB-FILE-FORMAT-1." (let ((fileset-trie (trie:make-trie))) (multiple-value-bind (root-namestring file-write-start-time) (parse-header-line-1 (read-line stream)) (loop for line = (read-line stream t) until (char= (char line 0) #\;) do (multiple-value-bind (stat-properties end) (parse-stat-properties-1 line) (fileset-trie-add fileset-trie line stat-properties :end end :strings-trie strings-trie)) finally (multiple-value-bind (file-write-end-time) (parse-footer-line-1 line) (setf (car fileset-trie) (list :file-write-start-time file-write-start-time :file-write-end-time file-write-end-time :root-namestring root-namestring))) (return fileset-trie))))) ;;; ;;; (defmethod write-database-file-1 ((fileset-trie list) (stream stream)) "Internal. Writes entries from FILESET-TRIE entries to STREAM in TWDB-FILE-FORMAT-1." (let ((props (car fileset-trie))) (format stream ";;; BEGIN TWDB-FILE-FORMAT-1~T~D~T~A~&" (getf props :file-write-start-time) (getf props :root-namestring)) (flet ((dump-entry (key stat-properties) (if (eql stat-properties props) ;XXX (return-from dump-entry nil)) (loop for (x . rest) on key do (write-string x stream) when rest do (write-char #\/ stream) finally (when (directory-p stat-properties) (write-char #\/ stream)) (write-char #\Tab stream)) (loop for ;; (property value . rest) (value . rest) on stat-properties ;; by #+nil #'cddr for check-property in USER::+STATBUF+ ;; do (assert (eq property check-property)) do (write value :stream stream) do (write-char (if rest #\Tab #\Newline) stream)))) (with-standard-io-syntax (trie:maptrie #'dump-entry fileset-trie))) (format stream ";;; END TWDB-FILE-FORMAT-1 ~D~&" (getf props :file-write-end-time)))) ;;; ---------------------------------------------------------------------- ;;; ;;; ENTRY-POINT ;;; ;;; (defun fileset-trie (root-directory &key (strings-trie *strings-trie*)) "Recursively descend ROOT-DIRECTORY and return a FILESET-TRIE." (let* ((root (truename root-directory)) (props (list :file-write-start-time (get-universal-time) :file-write-end-time nil :root-namestring (namestring root))) (fileset-trie (cons props nil)) (exclude-root-hack nil) (USER::*DIRED-TRUENAMEP* NIL) (USER::*DIRED-FOLLOW-LINKS* NIL)) (flet ((add-entry (pathname depth directory-p) (declare (ignorable depth directory-p)) (unless exclude-root-hack (when (equalp root pathname) (setq exclude-root-hack t) (return-from add-entry NIL))) (let ((string (enough-namestring pathname root)) (stat-properties (user::STAT2 pathname (loop for sym in USER::+STATBUF+ collect (symbol-value sym))))) (fileset-trie-add fileset-trie string stat-properties :strings-trie strings-trie)))) (USER::DIRED root #'add-entry) (setf (getf props :file-write-end-time) (get-universal-time))) fileset-trie)) ;;; ---------------------------------------------------------------------- ;;; ;;; (define-condition change (error) ((elem-1 :initarg :elem-1 :accessor change-compared-elem-1 :initform nil) (elem-2 :initarg :elem-2 :accessor change-compared-elem-2 :initform nil) (flags :initarg :flags :accessor change-compared-flags :initform nil) (uniq-1 :initarg :comm-23 :accessor change-comm-23 :initform nil) (uniq-2 :initarg :comm-13 :accessor change-comm-13 :initform nil) (comm :initarg :comm-12 :accessor change-comm-12 :initform nil)) (:report summarize-change)) (defun summarize-change (condition stream) (let ((fileset-trie-1 (change-compared-elem-1 condition)) (fileset-trie-2 (change-compared-elem-2 condition)) (stat-flags (change-compared-flags condition)) (uniq1 (change-comm-23 condition)) (uniq2 (change-comm-13 condition)) (comm (change-comm-12 condition))) (format stream "Change Detected.~ ~@[~%Compared FILESET 1: ~{~A~^ ~}~]~ ~@[~% With FILESET 2: ~{~A~^ ~}~]~ ~@[~% Using flags: ~{~A~^ ~}~]~ ~@[~%Unique to 1: ~A~]~ ~@[~%Unique to 2: ~A~]~ ~@[~%Changed items: ~A~]" (when fileset-trie-1 (list (USER:ISO-8601-DATE :utime (getf (car fileset-trie-1) :file-write-end-time)) (trie::trie-count fileset-trie-1) (getf (car fileset-trie-1) :root-namestring))) (when fileset-trie-2 (list (USER:ISO-8601-DATE :utime (getf (car fileset-trie-2) :file-write-end-time)) (trie::trie-count fileset-trie-2) (getf (car fileset-trie-2) :root-namestring))) stat-flags (and uniq1 (length uniq1)) (and uniq2 (length uniq2)) (and comm (length comm))))) (defvar *current-condition*) (defun compare-filesets (fileset-trie-1 fileset-trie-2 &key stat-flags) (let (uniq1 uniq2 comm x1 x2 x3 *current-condition*) (flet ((comm-23 (k v) (declare (ignore v)) (unless x1 (unless k (setq x1 t) (return-from comm-23 nil))) (setq uniq1 (cons k uniq1) #+nil (acons k v uniq1))) (comm-13 (k v) (declare (ignore v)) (unless x2 (unless k (setq x2 t) (return-from comm-13 nil))) (setq uniq2 (cons k uniq2) #+nil (acons k v uniq2))) (comm-12 (k v1 v2) (unless x3 (unless k (setq x3 t) (return-from comm-12 nil))) (let ((changes (loop for sym in USER::+STATBUF+ for val-1 in v1 for val-2 in v2 #|unless (eql val-1 val-2) collect (list sym val-1 val-2)|# if (if stat-flags (and (find sym stat-flags) (not (eql val-1 val-2))) (not (eql val-1 val-2))) return t))) (when changes (setq comm (cons k comm) #+nil (acons k changes comm)))))) (trie:comm-tries fileset-trie-1 fileset-trie-2 :comm-23 #'comm-23 :comm-13 #'comm-13 :comm-12 #'comm-12)) (when (or uniq1 uniq2 comm) (handler-bind ((change (lambda (c) (setq *current-condition* c)))) (cerror "Ignore" 'change :elem-1 fileset-trie-1 :elem-2 fileset-trie-2 :stat-flags stat-flags :comm-23 uniq1 :comm-13 uniq2 :comm-12 comm))))) (defun write-pathname (key fileset-trie &optional (stream *standard-output*)) (let ((stats (TRIE:GETTRIE key fileset-trie))) (assert stats nil "~S not found in fileset" key) (loop for (component . rest) on key do (write-string component stream) count (length component) if rest do (write-char #\/ stream) and count 1 else if (directory-p stats) do (write-char #\/ stream) and count 1 else if (symbolic-link-p stats) do (write-char #\@ stream) and count 1 else unless (regular-file-p stats) do (write-char #\* stream) and count 1)))