Re: Scheme book recommendations

[James LewisMoss <jimdres at mindspring dot com>]

>>>>> On 07 Jun 2000 20:43:13 +0200, Mikael Djurfeldt <mdj@mdj.nada.kth.se> said:

 Mikael> Mikael Djurfeldt <mdj@mdj.nada.kth.se> writes:
 >> "Peter C. Norton" <spacey@lenin.nu> writes:
 >>
 >> > I'm on it.  Who wants to help me?
 >>
 >> I'll do the server script from ch6.

 Mikael> I see no reason that we have to translate the perl examples
 Mikael> closely, so here's an example which I think is more fun:

Here's my most useful script (comments on my horrible scheme style are
ok :):

#!/usr/bin/guile -s
!#

(use-modules (ice-9 slib))

(define dir-sep #\/)

(define conf-file (string-append (getenv "HOME") "/.cvsdirs"))

(require 'glob)

(define (string-split str split-char)
  (let ((loc (string-index str split-char)))
    (if (not (equal? loc #f))
        (append (list (substring str 0 loc))
                (string-split (substring str (1+ loc)) split-char))
        (list str))))

(define (contains-glob-pattern part)
  (letrec ((test-chars '(#\* #\? #\[))
           (contains-glob-pattern-helper
            (lambda (part char-list)
              (if (null? char-list)
                  #f
                  (if (not (equal? (string-index part (car char-list)) #f))
                      #t
                      (contains-glob-pattern-helper part (cdr char-list)))))))
    (contains-glob-pattern-helper part test-chars)))

(define (combine-paths start end)
  (string-append start (string dir-sep) end))

(define (perl-glob dir-spec)
  (letrec ((perl-glob-part
            (lambda (parts)
              (if (null? (cdr parts))
                  parts
                  (let ((dir-path (combine-paths (car parts) (cadr parts))))
                    (if (contains-glob-pattern (combine-paths (car parts)
                                                              (cadr parts)))
                        (let* ((local-glob-pat (filename:match?? dir-path)))
                          (apply append
                                 (map (lambda (file-path)
                                        (perl-glob-part (cons file-path
                                                              (cddr parts))))
                                      (get-glob-files (car parts)
                                                      local-glob-pat))))
                        (if (equal? (stat:type (stat dir-path)) 'directory)
                            (perl-glob-part (cons dir-path (cddr parts)))
                            ())))))))
    (perl-glob-part (string-split dir-spec dir-sep))))

(define (get-glob-files dir-name pattern)
  (let ((ret '())
        (dir (opendir dir-name)))
    (do ((file (readdir dir) (readdir dir)))
        ((eof-object? file) ret)
      (let ((full-path (combine-paths dir-name file)))
        (if (and
             (not (string=? file "."))
             (not (string=? file ".."))
             (access? full-path F_OK)
             (eq? (stat:type (stat full-path))
                  'directory)
             (pattern full-path))
            (set! ret (append ret (list full-path))))))
    (closedir dir)
    ret))

(require 'printf)

(define the-file (open conf-file O_RDONLY))

(map (lambda (file-line)
       (map (lambda (dir)
              (printf "---------------------------------------------------\n")
              (printf "UPDATING %s\n" dir)
              (system (string-append "cd " dir " ; cvs update 2>&1")))
            (perl-glob file-line)))
     (do ((ret '())
          (line (read-line the-file) (read-line the-file)))
         ((eof-object? line) ret)
       (if (not (string=? line ""))
           (set! ret (append ret (list line))))))

(close the-file)


-- 
@James LewisMoss <dres@ioa.com>         |  Blessed Be!
@    http://www.ioa.com/~dres           |  Linux is kewl!
@"Argue for your limitations and sure enough, they're yours." Bach