#!/usr/bin/scsh -s
-*- scheme -*- !#
(define glob-patterns '("app-defaults/*" "bin/*" "info/*" "man/*/*"))

(define usage-message
  (let ((begin-bold      "\033[1m")
        (end-bold        "\033[m")
        (begin-underline "\033[4m")
        (end-underline   "\033[m"))
    (format #f
"~AUsage:~A
  ~Ainstall-links~A [~Aoption~A ...] ~Apackage~A ...

~AOptions:~A
  --force            Remove existing destinations, never prompt.
  --group=GROUP
  --help             Display this message and exit.
  --just-print       Don't actually link anything; just print the commands.
  --prefix=PREFIX    Install links in PREFIX (default is parent of package).
  --query            Prompt before overwrite.
  --user=USER
  --verbose          verbose mode

~AExamples:~A
  example% install-links --verbose /afs/wsi/sun4m_54/vim-3.0
  ln -s /afs/wsi/sun4m_54/vim-3.0/bin/vim /afs/.wsi/sun4m_54/bin/vim
  ln -s /afs/wsi/sun4m_54/vim-3.0/man/man1/vim.1 /afs/.wsi/sun4m_54/man/man1/vim.1

  example% install-links --prefix=/usr/local --verbose /afs/wsi/sun4m_54/vim-3.0
  ln -s /afs/wsi/sun4m_54/vim-3.0/bin/vim /usr/local/bin/vim
  ln -s /afs/wsi/sun4m_54/vim-3.0/man/man1/vim.1 /usr/local/man/man1/vim.1~%"
            begin-bold end-bold
            begin-underline end-underline
            begin-underline end-underline
            begin-underline end-underline
            begin-bold end-bold
            begin-bold end-bold)))

(define getopt
  (let ((option-sans-argument (make-regexp "^--([^=]+)$"))
        (option-with-argument (make-regexp "^--([^=]+)=(.*)$"))
        (unknown-option-error
         (lambda (option)
           (format (error-output-port)
            "unknown option `~A'~%try `~A --help'~%"
            option (car (command-line)))
           (exit 1)))
        (missing-argument-error
         (lambda (option)
           (format (error-output-port)
            "option `~A' requires an argument~%try `~A --help'~%"
            option (car (command-line)))
           (exit 1)))
        (superfluous-argument-error
         (lambda (option)
           (format (error-output-port)
            "option `~A' doesn't take an argument~%try `~A --help'~%"
            option (car (command-line)))
           (exit 1))))
    (lambda option-specifiers
      (let loop ((options '()) (rest command-line-arguments))
        (if (null? rest)
            (values options '())
            (let ((first (car rest)))
              (cond
               ((string=? "--" first) (values options (cdr rest)))
               ((regexp-exec option-sans-argument first) =>
                (lambda (match)
                  (let* ((option (match:substring match 1))
                         (foo    (assoc option option-specifiers)))
                    (cond
                     ((not foo)
                      (unknown-option-error option))
                     ((eq? #t (cdr foo))
                      (missing-argument-error option))
                     (else
                      (loop `((,option . #f) . ,options) (cdr rest)))))))
               ((regexp-exec option-with-argument first) =>
                (lambda (match)
                  (let* ((option (match:substring match 1))
                         (foo    (assoc option option-specifiers)))
                    (cond
                     ((not foo)
                      (unknown-option-error option))
                     ((eq? #f (cdr foo))
                      (superfluous-argument-error option))
                     (else
                      (loop `((,option . ,(match:substring match 2))
                              . ,options) (cdr rest)))))))
               (else
                (values options rest)))))))))

(define options   #f)
(define arguments #f)
(call-with-values (lambda ()
                    (getopt '("force"      . #f)
                            '("group"        . #t)
                            '("help"       . #f)
                            '("just-print" . #f)
                            '("prefix"     . #t)
                            '("query"      . #f)
                            '("user"        . #t)
                            '("verbose"    . #f)))
                  (lambda (opts args)
                    (set! options   opts)
                    (set! arguments args)))

(if (assoc "help" options)
    (begin
      (display usage-message)
      (exit)))

(if (null? arguments)
    (begin
      (display usage-message (error-output-port))
      (exit 1)))

(let ((foo (assoc "group" options)))
  (if foo
      (let ((group (cdr foo)))
        (with-errno-handler
         ((errno packet)
          ((errno/perm errno/inval)
           (format (error-output-port)
                   "cannot set group ~A: ~A~%" group (car packet))
           (exit 1)))
         (set-gid (let ((gid (string->number group)))
                    (if (integer? gid)
                        gid
                        (->gid group))))))))

(let ((foo (assoc "user" options)))
  (if foo
      (let* ((user (cdr foo))
             (uid  (let ((uid (string->number user)))
                     (if (integer? uid)
                         uid
                         (user-info:uid (user-info user))))))
        (with-errno-handler
         ((errno packet)
          ((errno/perm errno/inval)
           (format (error-output-port)
                   "cannot set user ~A: ~A~%" user (car packet))
           (exit 1)))
         (set-uid (let ((uid (string->number user)))
                    (if (integer? uid)
                        uid
                        (->uid user))))))))

(define (create-symlink-query old new)
  (with-errno-handler
   ((errno packet)
    ((errno/exist)
     (if (y-or-n? (string-append "create-symlink: " new
                                 (with-errno-handler
                                  ((errno packet)
                                   (else ""))
                                  (string-append " -> " (read-symlink new)))
                                 " already exists. Delete"))
         (begin
           (delete-filesys-object new)
           (create-symlink old new)))))
   (create-symlink old new)))

(define my-create-symlink
  ((lambda (foo)
     (lambda (old new)
       (if (with-errno-handler
            ((errno packet)
             ((errno/noent errno/acces errno/notdir errno/inval) #t))
            (not (string=? old (read-symlink new))))
           (with-errno-handler
            ((errno packet)
             ((errno/noent errno/acces errno/exist errno/notdir)
              (format (error-output-port)
                      "cannot ln -s ~A ~A: ~A~%" old new (car packet))))
            (foo old new)))))
   (cond
    ((assoc "just-print" options)
     (lambda (old new)
       (format #t "ln -s ~A ~A~%" old new)))
    ((and (assoc "query" options) (assoc "verbose" options))
     (lambda (old new)
       (format #t "ln -s ~A ~A~%" old new)
       (create-symlink-query old new)))
    ((and (assoc "force" options) (assoc "verbose" options))
     (lambda (old new)
       (format #t "ln -s ~A ~A~%" old new)
       (create-symlink old new 'force)))
    ((assoc "verbose" options)
     (lambda (old new)
       (format #t "ln -s ~A ~A~%" old new)
       (create-symlink old new)))
    ((assoc "query" options)
     (lambda (old new)
       (create-symlink-query old new)))
    ((assoc "force" options)
     (lambda (old new)
       (create-symlink old new 'force)))
    (else
     (lambda (old new)
       (create-symlink old new))))))

(define (my-glob dir)
  (with-errno-handler
   ((errno packet)
    ((errno/noent errno/acces errno/notdir)
     (format (error-output-port)
             "cannot cd ~A: ~A~%" dir (car packet))
     '()))
   (with-cwd dir (apply glob glob-patterns))))

(define afs-with-dot
  (let ((regexp (make-regexp "/afs/([^.].*)$")))
    (lambda (path)
      (let ((match (regexp-exec regexp path)))
        (if match
            (string-append "/afs/." (match:substring match 1))
            path)))))
 
(define afs-sans-dot
  (let ((regexp (make-regexp "/afs/\\.(.*)$")))
    (lambda (path)
      (let ((match (regexp-exec regexp path)))
        (if match
            (string-append "/afs/" (match:substring match 1))
            path)))))

(let* ((pwd (let ((pwd (getenv "PWD")))
              (if pwd
                  pwd
                  (begin
                    (format (error-output-port)
                            "environment variable PWD not defined~%")
                    (exit 1)))))
       (prefix (let ((foo (assoc "prefix" options)))
                 (if foo
                     (afs-with-dot
                      (file-name-as-directory
                       (expand-file-name (cdr foo) pwd)))
                     #f))))
       (map (lambda (dir)
              (let* ((sourcedir (afs-sans-dot
                                 (file-name-as-directory
                                  (expand-file-name dir pwd))))
                     (targetdir (if prefix
                                    prefix
                                    (afs-with-dot
                                     (file-name-directory
                                      (directory-as-file-name sourcedir))))))
                (for-each (lambda (file)
                       (my-create-symlink (string-append sourcedir file)
                                          (string-append targetdir file)))
                     (my-glob sourcedir))))
            arguments))
