#!/bin/sh
exec ${GUILE-guile} -e '(guile-baux sofix)' -s $0 "$@" # -*- scheme -*-
!#
;;; sofix --- smooth out things after $(LIBTOOL) --mode=install

;; Copyright (C) 2007, 2020 Thien-Thi Nguyen
;;
;; This program 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 3, or
;; (at your option) any later version.
;;
;; This program 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 should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Usage: sofix FLAGS DIR FOO.la...
;;
;; Change directory to DIR and do various things based on FOO.la
;; vars and FLAGS, a comma-separated list of symbols:
;;
;;  no-symlinks -- from the files in library_names=LIST, delete
;;                 those that are symlinks, and update FOO.la
;;                 vars ‘dlname’ and ‘library_names’ as well
;;
;;  no-la       -- delete FOO.la
;;
;;  ln-s-lib    -- symlink (or copy if no-la) FOO.la to libFOO.la
;;                 [default: remove any such symlinks found]
;;
;; To specify no flags, use "none".  Note, however, that "none"
;; does not prevent any libFOO.la files from being deleted anyway.
;;
;; Lastly, chmod -x the remaining regular (non-symlink) files.

;;; Code:

(define-module (guile-baux sofix)
  #:export (main)
  #:use-module ((guile-baux common) #:select (fs die check-hv qop<-args))
  #:use-module ((srfi srfi-1) #:select (every))
  #:use-module ((srfi srfi-13) #:select (string-tokenize))
  #:use-module ((srfi srfi-14) #:select (char-set:graphic
                                         char-set:ascii
                                         char-set-difference
                                         char-set-intersection
                                         string->char-set))
  #:use-module ((ice-9 popen) #:select (open-input-pipe
                                        close-pipe))
  #:use-module ((ice-9 rdelim) #:select (read-line)))

(define (DIE s . args)
  (die #f (apply fs (string-append (basename (car (command-line)))
                                   ": " s
                                   " (try --help)~%")
                 args)))

(define (strtok delims string)
  (string-tokenize
   string (char-set-difference
           ;; Clamp for performance.  However, DWR: likelihood
           ;; of non-ASCII library filenames low but non-zero.
           (char-set-intersection char-set:graphic char-set:ascii)
           (string->char-set delims))))

(define VALID-FLAGS '(no-la no-symlinks ln-s-lib))

(define (get-flags qop)                 ; => list of symbols, possibly empty
  (let* ((all (qop '()))
         (flags (if (null? all)
                    (DIE "Missing FLAGS")
                    (car all))))
    (cond ((string-null? flags)
           (DIE "Invalid FLAGS"))
          ((string=? "none" flags)
           '())                         ; rv 1
          ((false-if-exception
            (map string->symbol
                 (strtok "," flags)))
           => (lambda (ls)
                (if (every (lambda (sym)
                             (memq sym VALID-FLAGS))
                           ls)
                    ls                  ; rv 2
                    (DIE "Invalid FLAGS: ~S" flags))))
          (else
           (DIE "Invalid FLAGS: ~S" flags)))))

(define (get-dir qop)                   ; => directory (string)
  (let* ((all (qop '()))
         (dir (false-if-exception (cadr (qop '())))))
    (cond ((not dir)
           (DIE "Missing DIR"))
          ((or (not (file-exists? dir))
               (not (file-is-directory? dir)))
           (DIE "Invalid DIR: ~S" dir)))
    ;; rv
    dir))

(define (syfs s . args)
  (system (apply fs s args)))

(define (main/qop qop)
  (let ((flags (get-flags qop))
        (dir (get-dir qop)))

    (define (flag? flag)
      (memq flag flags))

    (define (one la)

      (define (sed var)
        (let* ((p (open-input-pipe (fs "sed '/^~A=/!d' ~A" var la)))
               (line (substring (read-line p) (1+ (string-length var)))))
          (close-pipe p)
          ;; rv
          (strtok "'" line)))

      (or (file-exists? la)
          (DIE "Cannot read ~A" la))

      (let ((dlname (car (sed "dlname")))
            (library_names (sed "library_names")))
         (and (flag? 'no-symlinks)
             (for-each
              (lambda (name)
                (cond ((eq? 'symlink (and (file-exists? name)
                                          (stat:type (lstat name))))
                       (delete-file name))
                      ((not (string=? dlname name))
                       ;; Replace values for both ‘dlname’, ‘library_names’.
                       (syfs "sed -e \"s/^\\(dlname=\\).*/\\1'~A'/\" \
                                  -e \"s/^\\(library_names=\\).*/\\1'~A'/\" \
                              ~A > ~AT"
                             name name la la)
                       (rename-file (fs "~AT" la) la)
                       (set! dlname name))))
              library_names))

        ;; rm -f lib$la
        (let ((lib (fs "lib~A" la)))
          (and (file-exists? lib)
               (delete-file lib)))

        (and (flag? 'ln-s-lib)
             (let ((rep (if (flag? 'no-la)
                            "cp"
                            "ln -s")))
               (syfs "~A ~A lib~A" rep la la)))

        ;; Lame (via ‘system’), or elegant?
        (syfs "chmod -x ~A ~A" la dlname)

        (and (flag? 'no-la)
             (delete-file la))))

    (chdir dir)
    (or (string=? dir (getcwd))
        (DIE "Could not change to directory ~A" dir))
    (for-each one (or (false-if-exception (cddr (qop '())))
                      '())))
  #t)

(define (main args)
  (check-hv args '((package . "Guile-BAUX")
                   (version . "3.0")
                   ;; 3.0 -- reimpl in Scheme; add to Guile-BAUX
                   ;; 2.0 -- impl in sh; independent
                   (help . commentary)))
  (exit (main/qop (qop<-args args '()))))

;;; sofix ends here
