;;;
;;; gauche.package.util - internal utilities used in package manager
;;;
;;;   Copyright (c) 2004-2024  Shiro Kawai  <shiro@acm.org>
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

;;; NB: this module is not intended for external use.

(define-module gauche.package.util
  (use gauche.process)
  (use gauche.termios)
  (use gauche.package)
  (use gauche.sequence)
  (use scheme.charset)
  (use util.match)
  (use file.util)
  (use file.filter)
  (use text.tr)
  (use srfi.13)
  (export run dry-run verbose-run get-password copy-templates
          find-package-name-and-version
          %gosh %shell %fix-path %find-file-in-paths))
(select-module gauche.package.util)

;; for windows (Msys)
(define (%gosh script)
  (cond-expand
   [gauche.os.windows #"gosh ~script"]
   [else script]))

;; for windows (Msys)
(define (%shell command)
  (cond-expand
   [gauche.os.windows
    (if-let1 sh (sys-getenv "SHELL")
      `("cmd.exe" "/c" ,sh "-c" ,command)
      `("cmd.exe" "/c" ,command))]
   [else command]))

;; for windows (Msys)
(define (%fix-path path)
  (cond-expand
   [gauche.os.windows
    (and path
         (if (sys-getenv "MSYSTEM")
           (shell-escape-string path 'posix)
           path))]
   [else path]))

;; for windows (Msys)
(define (%find-file-in-paths name)
  (cond-expand
   [gauche.os.windows
    (find-file-in-paths name :extensions '("exe"))]
   [else
    (find-file-in-paths name)]))

(define dry-run     (make-parameter #f))
(define verbose-run (make-parameter #f))

(define (run cmdline :key (stdin-string #f))
  (when (or (dry-run) (verbose-run))
    (print cmdline))
  (unless (dry-run)
    (let1 p (run-process (cond-expand
                          [gauche.os.windows
                           (if (string? cmdline)
                             (shell-tokenize-string cmdline 'posix)
                             cmdline)]
                          [else `("/bin/sh" "-c" ,cmdline)])
                         :input (if stdin-string :pipe :null)
                         :wait #f)
      (when stdin-string
        (let1 pi (process-input p)
          (display stdin-string pi)
          (flush pi)
          (close-output-port pi)))
      (process-wait p)
      (unless (zero? (process-exit-status p))
        (errorf "command execution failed: ~a" cmdline)))))

;; Read password from the terminal without echoing
(define (get-password)
  (with-output-to-file
      (cond-expand [gauche.os.windows "CON"] [else "/dev/tty"])
    (lambda () (display "Password: ") (flush)))
  (without-echoing #f read-line))

;; Determine package name and version heuristically
;; - If we have package.scm, just use it.
;; - If we have autoconf configure.ac, look for AC_INIT.
;; - If we have Scheme configure script, look for cf-init.
;; - Otherwise, look at the current directory name and VERSION file.
(define (find-package-name-and-version :key (top-srcdir "."))
  (or (and-let* ([f (build-path top-srcdir "package.scm")]
                 [ (file-exists? f) ]
                 [desc (path->gauche-package-description f)])
        (list (~ desc 'name)
              (~ desc 'version)))
      (and-let* ([f (build-path top-srcdir "configure.ac")]
                 [ (file-exists? f) ]
                 [x (find #/^\s*AC_INIT\(/ (file->string-list f))])
        (rxmatch-case x
          [#/AC_INIT\(\s*([\w-.]+)\s*,(?:\s*([\w-.]+))?/ (_ pkg ver)
           (list pkg ver)]
          [else #f]))
      (and-let* ([f (build-path top-srcdir "configure")]
                 [ (file-exists? f) ]
                 [s (guard (e [else #f]) (file->sexp-list f))]
                 [t (find (^x (and (pair? x) (eq? (car x) 'cf-init))) s)])
        (match t
          [('cf-init pkg ver . _) (list pkg ver)]
          [_ #f]))
      (and-let* ([vf (build-path top-srcdir "VERSION")]
                 [ (file-exists? vf) ]
                 [ver (string-trim-both (file->string vf))])
        (list ($ sys-basename $ sys-dirname $ simplify-path
                 $ sys-normalize-pathname vf :absolute #t)
              ver))))

;; Copy template files from SRCDIR to DESTDIR, with substituting names
;; suitable for an extention module.  Used by gauche-package generate.
;; PACKAGE-NAME should be a package name.  Extension-name is derived from it.
;; MODULE-NAME should be a symbol (e.g. foo.bar).  If not given, derived
;; from extension-name.
;; If there's already a file in the destination, it is overwritten, unless
;; PRESERVE is true.
;; Returns two lists: List of files copied, and list of files preserved.
(define (copy-templates srcdir dstdir package-name
                        :key (module-name #f)
                             (use-autoconf #f)
                             (scheme-only #f)
                             (verbose #f)
                             (license #f)
                             (licensor #f)
                             (preserve #f))
  (assume-type package-name <string>)
  (let* ([extension-name (string-tr package-name "A-Za-z_-" "a-za-z__")]
         [module-name (or module-name
                          (string->symbol extension-name))]
         [module-path (module-name->path module-name)]
         [dst-subdir  (sys-dirname module-path)]
         [gversion    (gauche-version)]
         [author-name (%author-name)]
         [license-name (ecase license
                         [(bsd bsd3) "BSD"]
                         [(mit) "MIT"]
                         [(#f) #f])])

    (define (filter-copy src dst executables configure-name)
      (let1 EXTENSION-NAME (string-upcase extension-name)
        (if (and preserve (file-exists? dst))
          (begin
            (when verbose
              (format #t "Skipping ~a: Destination exists.\n" dst))
            #f)
          (begin
            (when verbose
              (format #t "Installing ~a as ~a\n" src dst))
            (file-filter
             (^[in out]
               (port-for-each
                (^[line]
                  (display
                   (regexp-replace-all*
                    line
                    #/@@package@@/ package-name
                    #/@@modname@@/ (x->string module-name)
                    #/@@modpath@@/ (module-name->path module-name)
                    #/@@extname@@/ extension-name
                    #/@@EXTNAME@@/ EXTENSION-NAME
                    #/@@configure@@/ configure-name
                    #/@@gauche-version@@/ gversion
                    #/@@author@@/ (if author-name
                                    (write-to-string author-name)
                                    "")
                    #/@@year@@/ ($ sys-strftime "%Y" $ sys-localtime
                                   $ sys-time)
                    #/@@licensor@@/ (or licensor
                                        author-name
                                        "COPYRIGHT HOLDER")
                    #/@@license@@/ (if license-name
                                     (write-to-string license-name)
                                     ""))
                   out)
                  (newline out))
                (cut read-line in)))
             :input src
             :output dst)
            (when (member (sys-basename dst) executables)
              (sys-chmod dst #o755))
            #t))))

    (make-directory* (build-path dstdir dst-subdir))
    (let1 files (append (if use-autoconf
                          '("configure.ac")
                          '("configure"))
                        (if scheme-only
                          '("Makefile-pure-scheme.in"
                            "module-pure-scheme.scm")
                          '("Makefile.in" "extension.c"
                            "extension.h" "extensionlib.scm"
                            "module.scm" ))
                        (case license
                          [(bsd bsd3) '("COPYING--bsd3")]
                          [(mit) '("COPYING--mit")]
                          [(#f) '()])
                        '("package.scm" "test.scm"))
      (fold2 (^[file copied preserved]
               (let* ([src-path (build-path srcdir file)]
                      [dst-name (regexp-replace*
                                 file
                                 #/extension/ extension-name
                                 #/module/ (sys-basename module-path)
                                 #/-pure-scheme/ ""
                                 #/--bsd3/ ""
                                 #/--mit/ "")]
                      [dst-path (if (#/^module/ file)
                                  (build-path dstdir dst-subdir dst-name)
                                  (build-path dstdir dst-name))])
                 (if (filter-copy src-path dst-path
                                  '("configure")
                                  (if use-autoconf "configure" ""))
                   (values (cons dst-path copied) preserved)
                   (values copied (cons dst-path preserved)))))
             '() '() files))))

;; Retrieve author name and email from git config, if possible
(define (%author-name)
  (and-let* ([git (%find-file-in-paths "git")]
             [name  (process-output->string '(git config user.name)
                                            :error :null
                                            :on-abnormal-exit :ignore)]
             [ (and name (not (string-null? name))) ]
             [email (process-output->string '(git config user.email)
                                            :error :null
                                            :on-abnormal-exit :ignore)]
             [ (and email (not (string-null? email))) ])
    #"~name <~|email|>"))
