Automatic process: What's the problem?

[Craig Lanning <CLanning@pdesds1.atg.trc.scra.org>]

    Date: Mon, 9 Nov 1992 13:05 EST
    From: jiang@lia.di.epfl.ch (Tao JIANG)

    [... Message Removed ...]

We decided to do something similar in addition to our normal backup.  We
set up a background process which would wake up at a certain time every
night and make adjustments to a mirror directory so that it looked just
like our primary directory.  The code is at the end of this message.


Craig Lanning <CLanning@trc.scra.org>
Grumman Data Systems
North Charleston, SC

---------------------------------------------------------------------
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base: 10 -*-


#||

This function takes a source pathname, a destination pathname, and a
time of day.  It then creates a background process which, everyday
at TIME, will traverse the source tree and adjust the destination
tree to be a mirror backup.

Example:
	(update-mirror-backup "FOO:>" "BAR:>foo>" "3:00")

Every night at 3:00am the process named "Mirror [FOOBAR]" will
wakeup and adjust "BAR:>foo>" to be a mirror image of "FOO:>".  Note
that none of the files are marked as being backed up.

||#

(defun UPDATE-MIRROR-BACKUP (source destination time)
  (setq source (fs:parse-pathname source))
  (setq destination (fs:parse-pathname destination))
  (labels ((UPDATE-WAIT (time) (> (time:get-universal-time) time))
	   (UPDATE-TREE-INTERNAL (sroot droot)
	     (let ((add 0) (remove 0) sfiles dfiles)
	       (setf sfiles (cdr (fs:directory-list sroot :sorted)))
	       (setf dfiles (cdr (fs:directory-list droot :sorted)))
	       (loop for (path . props) in sfiles
		     ;; move new files to backup directory
		     unless (getf props :directory)
		       do (let ((dpath (fs:merge-pathnames droot path)))
			    (unless (probe-file dpath)
			      (copy-file path dpath)
			      (incf add))))
	       ;; remove non-existent files from backup directory
	       (loop with expunge? = nil
		     for (path . props) in dfiles
		     unless (probe-file (fs:merge-pathnames sroot path))
		       do (if (getf props :directory)
			      (let ((dfile (fs:merge-pathnames
					     (format nil "~A>" (send path :raw-name))
					     droot)))
				(incf remove (delete-tree dfile))
				(setq expunge? t))
			      (progn (send path :delete) (setq expunge? t)))
		     finally (when expunge? (send droot :expunge)))
	       ;; recurse into subdirectories
	       (loop for (path . props) in sfiles
		     when (getf props :directory)
		       do (let* ((nsroot (send path :pathname-as-directory))
				 (ndroot (fs:merge-pathnames
					   (format nil "~A>" (send path :raw-name))
					   droot)))
			    (unless (probe-file (send ndroot :directory-pathname-as-file))
			      ;; create the destination directory if needed
			      (send ndroot :create-directory))
			    (multiple-value-bind (sadd sremove)
				(update-tree-internal nsroot ndroot)
			      (incf add sadd) (incf remove sremove))))
	       (values add remove)))
	   (DELETE-TREE (root)
	     (let ((count 0) (files (cdr (fs:directory-list root :sorted))))
	       (loop for (path . props) in files
		     do (if (getf props :directory)
			    (let ((dpath (fs:merge-pathnames
					   (format nil "~A>" (send path :raw-name))
					   root)))
			      (incf count (delete-tree dpath)))
			    (progn (send path :delete) (incf count))))
	       (send root :expunge)
	       (send (send root :directory-pathname-as-file) :delete)
	       count))
	   (UPDATE-TREE (sroot droot time)
	     (loop for next-time = (time:parse-universal-time time) doing
	       (process:process-wait (format nil "Wait for ~\\time\\" next-time)
				     #'update-wait next-time)
	       (tv:notify nil "Mirror Backup: Begin")
	       (multiple-value-bind (add remove) (update-tree-internal sroot droot)
		 (tv:notify nil "Mirror Backup: ~D files copied" add)
		 (tv:notify nil "Mirror Backup: ~D files removed" remove))
	       (tv:notify nil "Mirror Backup: Complete")))
	   )
    (process:process-run-function
      `(:name ,(format nil "Mirror [~A~A]" (send source :host)
		      (send destination :host))
	:restart-after-reset t)
      #'update-tree source destination time)
    ))