#!/bin/sh
IFS=" "
exec scsh -s "$0" "$@"
!#
(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
  ~Auninstall-links~A [~Aoption~A ...] ~Apackage~A ...

~AOptions:~A
  --group=GROUP
  --help             Display this message and exit.
  --just-print       Don't actually delete anything; just print the commands.
  --prefix=PREFIX    Delete links in PREFIX (default is parent of package).
  --user=USER
  --verbose          verbose mode

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

  example% uninstall-links --prefix=/usr/local --verbose /afs/wsi/sun4m_54/vim-3.0
  rm /usr/local/bin/vim
  rm /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 '("group"      . #t)
                            '("help"       . #f)
                            '("just-print" . #f)
                            '("prefix"     . #t)
                            '("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 my-delete-symlink
  ((lambda (foo)
     (lambda (old new)
       (if (with-errno-handler
            ((errno packet)
             ((errno/noent errno/acces errno/notdir errno/inval) #f))
            (string=? old (read-symlink new)))
           (with-errno-handler
            ((errno packet)
             ((errno/acces)
              (format (error-output-port)
                      "cannot rm ~A: ~A~%" new (car packet))))
            (foo new)))))
   (cond
    ((assoc "just-print" options)
     (lambda (file)
       (format #t "rm ~A~%" file)))
    ((assoc "verbose" options)
     (lambda (file)
       (format #t "rm ~A~%" file)
       (delete-file file)))
    (else
     (lambda (file)
       (delete-file file))))))

(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-delete-symlink (string-append sourcedir file)
                                          (string-append targetdir file)))
                     (my-glob targetdir))))
            arguments))
