bug#40039: 'wrap-script' introduces spurious argument

[Brendan Tildesley <mail@brendan.scot>]

[-- Attachment #1: Type: text/plain, Size: 3908 bytes --]

I'm currently packaging libratbag which provides the cli interface 
ratbagctl. when launched without arguments, it normally the current devices

######################
## with wrap-program (correct):
b@ui ~/guix [env]$ ratbagctl
warbling-mara:       Logitech G102 Prodigy Gaming Mouse

b@ui ~/guix [env]$ head `which ratbagctl`
#!/gnu/store/29jhbbg1hf557x8j53f9sxd9imlmf02a-bash-minimal-5.0.7/bin/bash
export 
PYTHONPATH="/gnu/store/88v8lvs02sdqgzv7w96g19fvh8hffzzp-libratbag-0.13/lib/python3.7/site-packages/:/gnu/store/h4jkr0qg86zjn1kq6iq8v33pcadj9r13-python-evdev-1.3.0/lib/python3.7/site-packages/:/gnu/store/z5fdc5aa9hs4c3p79ajzgxhazv7702y8-python-pygobject-3.28.3/lib/python3.7/site-packages/"
exec -a "$0" 
"/gnu/store/88v8lvs02sdqgzv7w96g19fvh8hffzzp-libratbag-0.13/bin/.ratbagctl-real" 
"$@"


######################
## with wrap-script:
b@ui ~/guix [env]$ ratbagctl
usage: /gnu/store/754ylqjs68va7rswr3fscwa0kyazsbjq-profile/bin/ratbagctl 
<device>
        {info,name,profile,resolution,dpi,rate,button,led} ...
/gnu/store/754ylqjs68va7rswr3fscwa0kyazsbjq-profile/bin/ratbagctl 
<device>: error: invalid choice: 
'/gnu/store/754ylqjs68va7rswr3fscwa0kyazsbjq-profile/bin/ratbagctl' 
(choose from 'info', 'name', 'profile', 'resolution', 'dpi', 'rate', 
'button', 'led')

b@ui ~/guix [env]$ ratbagctl list
/gnu/store/754ylqjs68va7rswr3fscwa0kyazsbjq-profile/bin/ratbagctl 
<device>: error: invalid choice: 
'/gnu/store/754ylqjs68va7rswr3fscwa0kyazsbjq-profile/bin/ratbagctl' 
(choose from 'info', 'name', 'profile', 'resolution', 'dpi', 'rate', 
'button', 'led')
b@ui ~/guix [env]$ ratbagctl info rastkasnts atkatkaf ftbaontb 
aesbtabtowf ~5qawylftarsnvbawlpfyq
usage: /gnu/store/754ylqjs68va7rswr3fscwa0kyazsbjq-profile/bin/ratbagctl 
<device>
        {info,name,profile,resolution,dpi,rate,button,led} ...
/gnu/store/754ylqjs68va7rswr3fscwa0kyazsbjq-profile/bin/ratbagctl 
<device>: error: invalid choice: 
'/gnu/store/754ylqjs68va7rswr3fscwa0kyazsbjq-profile/bin/ratbagctl' 
(choose from 'info', 'name', 'profile', 'resolution', 'dpi', 'rate', 
'button', 'led')
b@ui ~/guix [env]$

b@ui ~/guix [env]$ head `which ratbagctl`
#!/gnu/store/0awhym5h0m890n0wq87y0dxznh14rk88-guile-next-3.0.1/bin/guile 
--no-auto-compile
#!#; Guix wrapper
#\-(begin (setenv "PYTHONPATH" 
"/gnu/store/1hcpppqc6268siki64vs1ygq1qsr8w35-libratbag-0.13/lib/python3.7/site-packages/:/gnu/store/h4jkr0qg86zjn1kq6iq8v33pcadj9r13-python-evdev-1.3.0/lib/python3.7/site-packages/:/gnu/store/z5fdc5aa9hs4c3p79ajzgxhazv7702y8-python-pygobject-3.28.3/lib/python3.7/site-packages/"))
#\-(let ((cl (command-line))) (apply execl 
"/gnu/store/608bvypsh90c58apvd2cgg3m9l2pwjqn-python-3.7.4/bin/python3" 
(car cl) (cons (car cl) (append (quote ("")) cl))))
#!/gnu/store/608bvypsh90c58apvd2cgg3m9l2pwjqn-python-3.7.4/bin/python3

####################

Here I make a copy of the guix build utils module and modify the 
wrap-script, removing #\space as suggested, so it defaults to 
char-set:graphic. This results in the above guile wrapper chaging to:

#\-(let ((cl (command-line))) (apply execl 
"/gnu/store/608bvypsh90c58apvd2cgg3m9l2pwjqn-python-3.7.4/bin/python3" 
(car cl) (cons (car cl) (append (quote ()) cl))))

The behaviour changes somewhat. Now running ratbagctl prints the 
commants list, which is what should happen when the wrong arguments are 
provided, e.g., `ratbagctl qwfqwfqf`


b@ui ~/guix [env]$ ratbagctl
usage: ratbagctl [OPTIONS] list
        ratbagctl [OPTIONS] <device> {COMMAND} ...


b@ui ~/guix [env]$ ratbagctl list
usage: /gnu/store/fgl1w0lh1pzqg8j4gi8j1yi29aa122ja-profile/bin/ratbagctl 
<device>
        {info,name,profile,resolution,dpi,rate,button,led} ...
/gnu/store/fgl1w0lh1pzqg8j4gi8j1yi29aa122ja-profile/bin/ratbagctl 
<device>: error: invalid choice: 'list' (choose from 'info', 'name', 
'profile', 'resolution', 'dpi', 'rate', 'button', 'led')


























[-- Attachment #2: 0001-WRAPSCRIPT.patch --]
[-- Type: text/x-patch, Size: 14218 bytes --]

From 3b5db2c77598961b0b60c901a9bbed8f0524a93f Mon Sep 17 00:00:00 2001
From: Brendan Tildesley <mail@brendan.scot>
Date: Sun, 22 Mar 2020 22:40:18 +1100
Subject: [PATCH] WRAPSCRIPT

---
 gnu/packages/gnome.scm | 131 ++++++++++++++++++++++++++++++++-
 my-wrap.scm            | 162 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 292 insertions(+), 1 deletion(-)
 create mode 100644 my-wrap.scm

diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm
index a08cd00d72..d614677214 100644
--- a/gnu/packages/gnome.scm
+++ b/gnu/packages/gnome.scm
@@ -27,7 +27,7 @@
 ;;; Copyright © 2017, 2018 nee <nee-git@hidamari.blue>
 ;;; Copyright © 2017 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mohammed Sadiq <sadiq@sadiqpk.org>
-;;; Copyright © 2017 Brendan Tildesley <mail@brendan.scot>
+;;; Copyright © 2017, 2020 Brendan Tildesley <mail@brendan.scot>
 ;;; Copyright © 2017, 2018 Rutger Helling <rhelling@mykolab.com>
 ;;; Copyright © 2018 Jovany Leandro G.C <bit4bit@riseup.net>
 ;;; Copyright © 2018 Vasile Dumitrascu <va511e@yahoo.com>
@@ -158,12 +158,14 @@
   #:use-module (gnu packages spice)
   #:use-module (gnu packages sqlite)
   #:use-module (gnu packages ssh)
+  #:use-module (gnu packages swig)
   #:use-module (gnu packages tex)
   #:use-module (gnu packages time)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages version-control)
   #:use-module (gnu packages video)
   #:use-module (gnu packages virtualization)
+  #:use-module (gnu packages valgrind)
   #:use-module (gnu packages vpn)
   #:use-module (gnu packages web)
   #:use-module (gnu packages webkit)
@@ -186,6 +188,10 @@
   #:use-module (guix utils)
   #:use-module (guix gexp)
   #:use-module (guix monads)
+  #:use-module (guix)
+
+  #:use-module (my-wrap)
+
   #:use-module (guix store)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1))
@@ -9956,3 +9962,126 @@ manage remote and virtual systems.")
               license:cc-by2.0
               ;; For all others.
               license:lgpl2.0+))))
+
+
+(define-public python-evdev
+  (package
+    (name "python-evdev")
+    (version "1.3.0")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (pypi-uri "evdev" version))
+       (sha256
+        (base32
+         "0kb3636yaw9l8xi8s184w0r0n9ic5dw3b8hx048jf9fpzss4kimi"))))
+    (build-system python-build-system)
+    (native-inputs
+     `(("kernel-headers" ,linux-libre-headers)))
+    (arguments
+     `(#:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'patch-patch
+           (lambda* (#:key inputs #:allow-other-keys)
+             (substitute* "setup.py"
+               (("/usr/include/linux")
+                (string-append
+                 (assoc-ref inputs "kernel-headers") "/include/linux")))
+             #t)))))
+    (home-page
+     "https://github.com/gvalkov/python-evdev")
+    (synopsis
+     "Bindings to the Linux input handling subsystem")
+    (description
+     "Bindings to the Linux input handling subsystem")
+    (license license:lgpl2.1)))
+
+(define-public libratbag
+  (package
+    (name "libratbag")
+    (version "0.13")
+    (source (origin
+              (method url-fetch)
+              (uri
+               (string-append
+                "https://github.com/libratbag/libratbag/archive/v" version ".tar.gz"))
+              (file-name (string-append name "-" version ".tar.gz"))
+              (sha256
+               (base32
+                "1j8ryzrljqcp0c1wqzzpgr5fqdmwqr5z99avkxwfs7kqwm8ii9xh"))))
+    (build-system meson-build-system)
+    (native-inputs `(("pkg-config" ,pkg-config)
+                     ("check" ,check)
+                     ("swing" ,swig)
+                     ("valgrind" ,valgrind)))
+    (inputs `(("guile" ,guile-3.0)   ;;; for wrap-script
+              ("glib" ,glib)
+              ("json-glib" ,json-glib)
+              ("libevdev" ,libevdev)
+              ("udev" ,eudev)
+                                        ;("gobject-introspection" ,gobject-introspection)
+              ("python-pygobject" ,python-pygobject)
+              ("python-evdev" ,python-evdev)
+              ("libsystemd" ,elogind)
+
+              ))
+    (arguments
+     `(#:imported-modules ((my-wrap)
+                           (guix build meson-build-system)
+                           (guix build gnu-build-system)
+                           (guix build utils)
+                           (guix build glib-or-gtk-build-system)
+                           (guix build gremlin)
+                           (guix elf))
+       ;;#:modules ((wrap))
+       #:configure-flags
+       (list "-Dsystemd=false"
+             "-Dlogind-provider=elogind")
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'install 'wrap
+           (lambda* (#:key inputs outputs #:allow-other-keys)
+
+             (use-modules (my-wrap))
+
+
+             (let*
+                 ((out (assoc-ref outputs "out" ))
+                  (site "/lib/python3.7/site-packages/")
+                  (out-site (string-append (assoc-ref outputs "out" ) site))
+                  (evdev (string-append (assoc-ref inputs "python-evdev") site))
+                  (pygo (string-append (assoc-ref inputs "python-pygobject") site))
+
+                  (python-wrap
+                   `("PYTHONPATH" = (,out-site ,evdev ,pygo)))
+
+                  (gi-wrap ;; wraps json-glibs girepository directory. doesnt seem to matter at all??
+                   `("GI_TYPELIB_PATH" = (,(getenv "GI_TYPELIB_PATH")))))
+
+               ;; Do we even need to wrap the daemon?
+               ;; (wrap-program (string-append out "/bin/" "ratbagd")
+               ;;   python-wrap ;; gi-wrap
+               ;;   )
+               ;; TODO: switch to wrap-script when it's fixed
+               (wrap-script** (string-append out "/bin/" "ratbagctl")
+                              python-wrap ;; gi-wrap
+                              )
+
+               #t))))))
+    (home-page "https://github.com/libratbag/libratbag")
+    (synopsis "DBus daemon for configuring gaming mice")
+    (description "libratbag provides ratbagd, a DBus daemon to configure input
+devices, mainly gaming mice.  The daemon provides a generic way to access the
+various features exposed by these mice and abstracts away hardware-specific
+and kernel-specific quirks. There is also the ratbagctl command line interface
+for configuring devices.
+
+libratbag currently supports devices from Logitech, Etekcity, GSkill, Roccat,
+Steelseries.
+
+ratbagd can be enabled by adding the following service to your
+operating-system definition:
+(simple-service 'ratbagd dbus-root-service-type (list libratbag))
+")
+    (license license:expat)))
diff --git a/my-wrap.scm b/my-wrap.scm
new file mode 100644
index 0000000000..f47ea210f6
--- /dev/null
+++ b/my-wrap.scm
@@ -0,0 +1,162 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (my-wrap)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-60)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 threads)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (guix build utils)
+  #:export ( wrap-script**))
+
+\f
+;;;
+;;; Guile 2.0 compatibility later.
+;;;
+
+;; The bootstrap Guile is Guile 2.0, so provide a compatibility layer.
+
+(define wrap-script**
+  (let ((interpreter-regex
+         (make-regexp
+          (string-append "^#! ?(/[^ ]+/bin/("
+                         (string-join '("python[^ ]*"
+                                        "Rscript"
+                                        "perl"
+                                        "ruby"
+                                        "bash"
+                                        "sh") "|")
+                         "))( ?.*)")))
+        (coding-line-regex
+         (make-regexp
+          ".*#.*coding[=:][[:space:]]*([-a-zA-Z_0-9.]+)")))
+    (lambda* (prog #:key (guile (which "guile")) #:rest vars)
+      "Wrap the script PROG such that VARS are set first.  The format of VARS
+is the same as in the WRAP-PROGRAM procedure.  This procedure differs from
+WRAP-PROGRAM in that it does not create a separate shell script.  Instead,
+PROG is modified directly by prepending a Guile script, which is interpreted
+as a comment in the script's language.
+
+Special encoding comments as supported by Python are recreated on the second
+line.
+
+Note that this procedure can only be used once per file as Guile scripts are
+not supported."
+      (define update-env
+        (match-lambda
+          ((var sep '= rest)
+           `(setenv ,var ,(string-join rest sep)))
+          ((var sep 'prefix rest)
+           `(let ((current (getenv ,var)))
+              (setenv ,var (if current
+                               (string-append ,(string-join rest sep)
+                                              ,sep current)
+                               ,(string-join rest sep)))))
+          ((var sep 'suffix rest)
+           `(let ((current (getenv ,var)))
+              (setenv ,var (if current
+                               (string-append current ,sep
+                                              ,(string-join rest sep))
+                               ,(string-join rest sep)))))
+          ((var '= rest)
+           `(setenv ,var ,(string-join rest ":")))
+          ((var 'prefix rest)
+           `(let ((current (getenv ,var)))
+              (setenv ,var (if current
+                               (string-append ,(string-join rest ":")
+                                              ":" current)
+                               ,(string-join rest ":")))))
+          ((var 'suffix rest)
+           `(let ((current (getenv ,var)))
+              (setenv ,var (if current
+                               (string-append current ":"
+                                              ,(string-join rest ":"))
+                               ,(string-join rest ":")))))))
+      (let-values (((interpreter args coding-line)
+                    (call-with-ascii-input-file prog
+                      (lambda (p)
+                        (let ((first-match
+                               (false-if-exception
+                                (regexp-exec interpreter-regex (read-line p)))))
+                          (values (and first-match (match:substring first-match 1))
+                                  (and first-match (match:substring first-match 3))
+                                  (false-if-exception
+                                   (and=> (regexp-exec coding-line-regex (read-line p))
+                                          (lambda (m) (match:substring m 0))))))))))
+        (if interpreter
+            (let* ((header (format #f "\
+#!~a --no-auto-compile
+#!#; ~a
+#\\-~s
+#\\-~s
+"
+                                   guile
+                                   (or coding-line "Guix wrapper")
+                                   (cons 'begin (map update-env
+                                                     (match vars
+                                                       ((#:guile _ . vars) vars)
+                                                       (_ vars))))
+                                   `(let ((cl (command-line)))
+                                      (apply execl ,interpreter
+                                             (car cl)
+                                             (cons (car cl)
+                                                   (append
+                                                    ',(string-tokenize args)
+                                                    cl))))))
+                   (template (string-append prog ".XXXXXX"))
+                   (out      (mkstemp! template))
+                   (st       (stat prog))
+                   (mode     (stat:mode st)))
+              (with-throw-handler #t
+                (lambda ()
+                  (call-with-ascii-input-file prog
+                    (lambda (p)
+                      (format out header)
+                      (dump-port p out)
+                      (close out)
+                      (chmod template mode)
+                      (rename-file template prog)
+                      (set-file-time prog st))))
+                (lambda (key . args)
+                  (format (current-error-port)
+                          "wrap-script: ~a: error: ~a ~s~%"
+                          prog key args)
+                  (false-if-exception (delete-file template))
+                  (raise (condition
+                          (&wrap-error (program prog)
+                                       (type key))))
+                  #f)))
+            (raise (condition
+                    (&wrap-error (program prog)
+                                 (type 'no-interpreter-found)))))))))
+\f
-- 
2.25.1