cron-walk.scm 2.1

fork and exec is nice but fork and load is faster (especially if the
parent preloads modules commonly used by the chidlren).  re-using one
log file helps as well.  for more info, see:

  http://www.glug.org/maint/explanation.html

ok, i've gotten my scheme fix for now.  back to the grindstone...

thi


___________________________________________
#!/bin/sh
exec guile -s $0 "$@" # -*- scheme -*-
!#
;;; ID: cron-walk.scm,v 1.28 2004/02/04 21:24:37 ttn Rel
;;;
;;; Copyright (C) 2001-2004 Thien-Thi Nguyen
;;; This program is part of ttn-do, released under GNU GPL v2 with ABSOLUTELY
;;; NO WARRANTY.  See http://www.gnu.org/copyleft/gpl.txt for details.

;;; Commentary:

;; Usage: cron-walk [--debug] [--load FILE ...] WHEN DIR [DIR...]
;;
;; Find executable .cron files under DIR(s) and load them DFS-style (parent
;; dir last) w/ single arg WHEN, first changing to that directory.  Output is
;; collected and mailed out only on failure.  Loading is done into a child
;; process, with the `command-line' proc rewritten.
;;
;; Command-line option "--load FILE" (or "-l FILE" for short) loads FILE
;; prior to doing the walk.  This option can be given multiple times.
;;
;; Dependencies: Env var "DEBUG_CRON_WALK" set causes output logs to be mailed
;; regardless of .cron return value.  This can also be enabled w/ command-line
;; option "--debug".  Env vars "MAILTO", "USER" and "LOGNAME" are consulted in
;; that order to determine the mail recipient.

;;; Code:

(use-modules (database tmpfile))

(define *LOG* (tmpfile))

(define *spewful?* #f)
(define *job-type* #f)

(define *stats* '())

(define (yo! stat)
  (set! *stats* (assq-set! *stats* stat (1+ (or (assq-ref *stats* stat) 0)))))

(define (load-dot-cron)
  (yo! 'load-dot-cron)
  (let ((pid (primitive-fork)))
    (if (= 0 pid)
        (let ((nice-exit (lambda (val)
                           (throw 'cron-walk-nice-exit val)))
              (orig-quit quit)
              (rv #f))                  ; cynical bastard
          (set! exit nice-exit)
          (set! quit nice-exit)
          (seek *LOG* 0 SEEK_SET)
          (truncate-file *LOG*)
          (set-current-output-port *LOG*)
          (set-current-error-port *LOG*)
          (display "BEG: ") (display (get-internal-real-time)) (newline)
          (catch 'cron-walk-nice-exit
                 (lambda () (load-from-path ".cron"))
                 (lambda (key val) (set! rv val)))
          (display "END: ") (display (get-internal-real-time)) (newline)
          (orig-quit rv)
          ;; should never get here
          lkasdjflaskjdf)
        (cdr (waitpid pid)))))

(use-modules (ice-9 popen) (scripts slurp))

(define (execute-cron-job)
  (let ((res (load-dot-cron)))
    (or (and (not *spewful?*) (= 0 res))
        (let ((buf (make-string (seek *LOG* 0 SEEK_CUR)))
              (p (open-output-pipe
                  (format #f "mail -s~A~A:~A:~A ~A"
                          (if *spewful?* "DEBUG_CRON_WALK:" "")
                          *job-type* res (getcwd)
                          (or (getenv "MAILTO")
                              (getenv "USER")
                              (getenv "LOGNAME")
                              "root")))))
          (yo! 'badness)
          (seek *LOG* 0 SEEK_SET)
          (slurp-file! buf *LOG* 0 (string-length buf) 0)
          (display buf p)
          (force-output p)
          (close-pipe p)
          (usleep 1000)))))

(define (check-and-go-proc ht)
  (lambda (filename statinfo flag base level)
    (yo! 'check)
    (or (and (string=? ".cron" (substring filename base))
             (< 0 (logand #o100 (stat:perms statinfo)))
             (hash-set! ht (substring filename 0 (1- base)) #t))
        (and (eq? flag 'directory-processed)
             (hash-ref ht filename)
             (execute-cron-job)))
    #t))

(use-modules ((ice-9 ftw) #:select (nftw)))

(define (cron-walk dirs)
  (for-each (lambda (dir)
              (nftw dir (check-and-go-proc (make-hash-table 31))
                    'chdir 'depth))
            dirs))

(define (main/qop qop)
  (set! *spewful?* (or (getenv "DEBUG_CRON_WALK")
                       (qop 'debug)))
  (qop 'load (lambda (ls)
               (for-each load-from-path (if (pair? ls) ls (list ls)))))
  (or (< 1 (length (qop '())))
      (let ((me (car (command-line))))
        (execl me me "--help")))
  (set! *job-type* (car (qop '())))
  (set! command-line (lambda () (list ".cron" *job-type*)))
  (cron-walk (cdr (qop '())))
  (and *spewful?* (for-each (lambda (pair)
                              (format #t "~A: ~A\n" (car pair) (cdr pair)))
                            *stats*))
  #t)

(use-modules ((scripts PROGRAM) #:select (HVQC-MAIN)))

;; do it!
(HVQC-MAIN (command-line) main/qop
           '(version . "2.1")
           ;; 2.1 -- display simple stats if --debug
           ;; 2.0 -- use "load" instead of "system", support `--load'
           ;; 1.2 -- supports command-line option `--debug'
           ;; 1.1 -- supports env var `DEBUG_CRON_WALK'
           ;; 1.0 -- plain
           '(usage . commentary)
           '(package . "ttn-do")
           '(option-spec (debug)
                         (load (single-char #\l) (value #t)
                               (merge-multiple? #t))))

;;; cron-walk.scm,v1.28 ends here


_______________________________________________
Guile-user mailing list
[email protected]
http://mail.gnu.org/mailman/listinfo/guile-user