From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Thien-Thi Nguyen Newsgroups: gmane.lisp.guile.user,gmane.lisp.guile.sources Subject: cron-walk.scm 2.1 Date: Thu, 05 Feb 2004 01:32:15 +0100 Sender: guile-user-bounces+guile-user=m.gmane.org@gnu.org Message-ID: Reply-To: ttn@glug.org NNTP-Posting-Host: deer.gmane.org X-Trace: sea.gmane.org 1075940862 21996 80.91.224.253 (5 Feb 2004 00:27:42 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Thu, 5 Feb 2004 00:27:42 +0000 (UTC) Cc: guile-user@gnu.org Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Thu Feb 05 01:27:29 2004 Return-path: Original-Received: from monty-python.gnu.org ([199.232.76.173]) by deer.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 1AoXMe-0000Pt-00 for ; Thu, 05 Feb 2004 01:27:29 +0100 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.24) id 1AoXLf-0006e4-0i for guile-user@m.gmane.org; Wed, 04 Feb 2004 19:26:27 -0500 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.24) id 1AoXHh-00047K-I1 for guile-user@gnu.org; Wed, 04 Feb 2004 19:22:21 -0500 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.24) id 1AoXH4-0003iv-4v for guile-user@gnu.org; Wed, 04 Feb 2004 19:22:13 -0500 Original-Received: from [151.37.47.229] (helo=surf.glug.org) by monty-python.gnu.org with esmtp (Exim 4.24) id 1AoXGW-0003U5-I3; Wed, 04 Feb 2004 19:21:08 -0500 Original-Received: from ttn by surf.glug.org with local (Exim 3.35 #1 (Debian)) id 1AoXRH-0000ip-00; Thu, 05 Feb 2004 01:32:15 +0100 Original-To: guile-sources@gnu.org X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.2 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Xref: main.gmane.org gmane.lisp.guile.user:2757 gmane.lisp.guile.sources:96 X-Report-Spam: http://spam.gmane.org/gmane.lisp.guile.user:2757 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 Guile-user@gnu.org http://mail.gnu.org/mailman/listinfo/guile-user