!#
;; Copyright (C) 2006 Dale Mellor
;;
;; This is a stand-alone program for manipulating directories of Xorg tarballs.
;;
;; This is free software; you can redistribute it and/or modify it under the
;; terms of the GNU General Public License as published by the Free Software
;; Foundation; either version 2, or (at your option) any later version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT ANY
;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
;; A PARTICULAR PURPOSE. See the GNU General Public License for more details.
;;
;; You can see the GNU General Public License online at
;; http://www.gnu.org/copyleft/gpl.html, or you can write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;; USA.
;; This program is designed to merge files from 'everything' directories of 7.1
;; and 7.0 tarballs, into a single directory containing only the latest version
;; of each file.
;;
;; This program will scan the contents of build-script (a shell script) for all
;; directives which specify the building of a tarball. It will look through the
;; tar-directories, and take the first version of each tarball that it finds
;; (thus the 7.1 tarballs will be preferred over the 7.0 ones), and will make a
;; link to that tarball in the build-directory.
;;**********************************************************************
;; USER-DEFINEABLE SECTION
;;**********************************************************************
;; The directory where the links to tar files end up.
(define build-directory "build-dir")
;; The script from where we derive the names of all packages.
(define build-script "build-from-tarballs.sh")
;; The extension on the tar files.
(define tar-extension "bz2")
;; List of directories where we look for tar files. Order is significant: the
;; first file found in the earliest directory in the list will be linked.
(define tar-directories '("7.1" "7.0"))
;;**********************************************************************
;; NO MORE USER CHANGES PAST THIS POINT
;;**********************************************************************
;; We want to use the read-line function, and regexps.
(use-modules (ice-9 rdelim) (ice-9 regex))
;; Check to see if the destination directory exists, and try to create it if
;; not.
(catch 'system-error
(lambda ()
(if (not (eq? (stat:type (stat build-directory)) 'directory))
(begin
(display "Output is NOT a directory.") (newline)
(primitive-exit 1))))
(lambda (key . args)
(mkdir build-directory)))
;; Look for a file in the given directory whose name begins with name-start and
;; fits the pattern for an X tarball. If found, create a link to the found file
;; in the destination directory. Return #t if the operation was successful, #f
;; if no file was found.
(define (find-link-file directory name-start)
(let ((regexp (make-regexp (string-append "^" name-start "-.*\\.tar\\."
tar-extension "$")))
(dir (opendir directory)))
(let loop ((file-name (readdir dir)))
(if (eof-object? file-name)
#f
(if (regexp-exec regexp file-name)
(let ((destination (string-append build-directory "/" file-name)))
(if (not (access? destination F_OK))
(link (string-append directory "/" file-name) destination))
#t)
(loop (readdir dir)))))))
;; For each package name extracted from the X build script, try to link an
;; appropriate file from the source tarball directories...
(for-each
;; This function is called for every package name extracted from the X build
;; script file. The action is to loop through all the tar source directories,
;; attempting to link an appropriate file into the destination directory (using
;; the above function). The loop continues until either the action is
;; successful or the list of directories is exhausted.
(lambda (package)
(let loop ((tar-file tar-directories))
(if (not (null? tar-file))
(if (not (find-link-file (car tar-file) package))
(loop (cdr tar-file))))))
;; This code runs through the lines of the X build script, returning a list of
;; package names which appear in build directives in that file.
(let ((regexp
(make-regexp
"build[[:space:]]+([^[:space:]]+)[[:space:]]+([^[:space:]]+)")))
(with-input-from-file build-script
(lambda ()
(do ((packages '()) (line (read-line) (read-line)))
((eof-object? line) packages)
(let ((match (regexp-exec regexp line)))
(if match
(set! packages (cons (match:substring match 2)
packages))))))))) 
