lisp/gnu/bash.scm

   1 ;;; bash.scm ---
   2
   3 ;; Copyright (C) 2014 Dmitry Bogatov <Dmitry Bogatov <KAction@gnu.org>>
   4
   5 ;; Author: Dmitry Bogatov <Dmitry Bogatov <KAction@gnu.org>>
   6
   7 ;; This program is free software; you can redistribute it and/or
   8 ;; modify it under the terms of the GNU General Public License
   9 ;; as published by the Free Software Foundation; either version 3
  10 ;; of the License, or (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;;; Code:
  23
  24 (define-module (gnu bash)
  25   #:export ((bash-eval . eval)))
  26 (use-modules (system foreign))
  27 (use-modules (system ffi))
  28 (use-modules (ice-9 match))
  29 (use-modules (ice-9 format))
  30 (use-modules (ice-9 curried-definitions))
  31
  32 (define-syntax-rule (define-public-from-c-code name)
  33   (begin
  34     (define name (false-if-exception (@ (gnu bash internal) name)))
  35     (export name)))
  36
  37 (define-public-from-c-code array->alist)
  38 (define-public-from-c-code bind-dynamic-variable)
  39
  40 ;; Since interface, provided by (system ffi) contains too much details
  41 ;; of Bash internals, we use this macro to provide more clean
  42 ;; interface.
  43 ;;
  44 ;; `define-override` works absolutely same as define*, but defines in body
  45 ;; `this-proc` symbol, referring to previous value of procedure variable.
  46 (define-syntax define-override
  47   (lambda (x)
  48     (syntax-case x ()
  49       ((_ (name arg ...) stmt stmt* ...)
  50        (with-syntax ((this-proc (datum->syntax x 'this-proc)))
  51          #'(define name
  52              (let ((this-proc name))
  53                (export name)
  54                (lambda* (arg ...) stmt stmt* ...))))))))
  55
  56 (define* (pointer-increment ptr #:optional (offset (sizeof '*)))
  57   (make-pointer (+ (pointer-address ptr) offset)))
  58
  59 ;; Flags is implementation detail, it is not actually useful for end-user,
  60 ;; so I save code and maintenance not decoding them.
  61 (define-ffi-struct alias: ((string: name) (string: value) (int: flags)))
  62
  63 ;; This is a bit tricky because of terminology fuss.
  64 ;; Address is, well, pointer to pointer to struct alias.
  65 ;; Pointer is, pointer to struct alias. See diagram, where
  66 ;; arrow means pointer dereferencing.
  67 ;;
  68 ;;  +-----------------+         +---------+        +----------------------+
  69 ;;  | address := argv |  --*>   | pointer |  --*>  + name | value | flags + (struct alias)
  70 ;;  +-----------------+         +---------+        +----------------------+
  71 ;;
  72 ;;  +-----------------+         +---------+        +----------------------+
  73 ;;  |     address     |  --*>   | pointer |  --*>  + name | value | flags + (struct alias)
  74 ;;  +-----------------+         +---------+        +----------------------+
  75 ;;
  76 ;;  ...
  77 ;;
  78 ;;  +-----------------+         +---------+
  79 ;;  |     address     |  --*>   |   NULL  |
  80 ;;  +-----------------+         +---------+
  81 (define (pointer->argv<alias> argv)
  82   (if (null-pointer? argv)
  83       '()
  84     (let loop ((address argv) (acc '()))
  85       (let ((pointer (dereference-pointer address)))
  86         (if (null-pointer? pointer)
  87             acc
  88           (loop (pointer-increment address)
  89                 (cons (pointer->alias pointer) acc)))))))
  90
  91 (define-ffi-object argv<alias>:
  92   #:decoder pointer->argv<alias>
  93   #:free c-free)
  94
  95 (define-ffi all-aliases (-> #:alloc argv<alias>:))
  96 (define-override (all-aliases)
  97   (define (alias->pair a)
  98     (match a
  99       (($ <struct-alias> name value) (cons name value))))
 100   (map alias->pair (this-proc)))
 101
 102
 103 (define-ffi add-alias ((#:const string-like: name) (#:const string-like: value) -> void:))
 104 (define-ffi get-alias-value ((#:const string-like: name) -> ?string:))
 105 (export add-alias get-alias-value)
 106
 107 (define-ffi remove-alias ((#:const string-like: name) -> int:))
 108 (define-override (remove-alias name)
 109   (let ((successfully-removed? (not {(this-proc name) = -1})))
 110     successfully-removed?))
 111
 112 (define-ffi delete-all-aliases (-> void:))
 113 (define-ffi alias-expand ((#:const string-like: name) -> #:alloc string:))
 114 (export alias-expand delete-all-aliases)
 115
 116 (define-extern (int: last-command-exit-value))
 117 (define-syntax $? (identifier-syntax (last-command-exit-value)))
 118 (export $?)
 119
 120 (define-ffi-mask eval-flags:
 121   ((nonint    #x001)
 122    (interact  #x002)
 123    (nohist    #x004)
 124    (nofree    #x008)
 125    (resetline #x010)
 126    (parseonly #x020)
 127    (nolongjmp #x040)))
 128
 129 ;; It is unsafe, since at least following is true:
 130 ;;
 131 ;;  * If errexit is set, it segfaults
 132 ;;
 133 ;; For safe version see bash-eval.
 134 (define-ffi unsafe-evalstring ((#:const string: string) (#:const string: from) eval-flags: -> int:)
 135   #:symbol "evalstring")
 136
 137 ;; Force `nofree` flag, or Bash will attempt to free what it should not.
 138 (define-override (unsafe-evalstring string from flags)
 139   (this-proc string from (cons 'nofree flags)))
 140
 141 (define (unsafe-format/eval . args)
 142   (unsafe-evalstring (apply format #f args) "(gnu bash)" '(nohist)))
 143
 144 (define (enable-option-argument opt)
 145   (format #f "-o ~a" opt))
 146 (define (disable-option-argument opt)
 147   (format #f "+o ~a" opt))
 148
 149 (define (make-restore-shellopts-thunk options)
 150   (let* ((shellopts-string (get-string-value "SHELLOPTS"))
 151          (shellopts (string-split shellopts-string #\:))
 152          (shellopts-symbols (map string->symbol shellopts)))
 153     (define (option->set-argument opt)
 154       (if (member opt shellopts-symbols)
 155           (enable-option-argument opt)
 156         (disable-option-argument opt)))
 157     (lambda ()
 158       (define saved-$? (last-command-exit-value))
 159       (unsafe-format/eval "set ~{~a ~}" (map option->set-argument options))
 160       (set! (last-command-exit-value) saved-$?))))
 161
 162 (define ((make-enable-shellopts-thunk options))
 163   (unsafe-format/eval "set ~{-o ~a ~}" options))
 164
 165 (define ((make-disable-shellopts-thunk options))
 166   (unsafe-format/eval "set ~{+o ~a ~}" options))
 167
 168 (define (call-with-shellopts options thunk)
 169   (dynamic-wind
 170     (make-enable-shellopts-thunk options)
 171     thunk
 172     (make-restore-shellopts-thunk options)))
 173
 174 (define (call-without-shellopts options thunk)
 175   (dynamic-wind
 176     (make-disable-shellopts-thunk options)
 177     thunk
 178     (make-restore-shellopts-thunk options)))
 179
 180 (define-syntax-rule (with-shellopts (opt opt* ...) stmt stmt* ...)
 181   (call-with-shellopts '(opt opt* ...) (lambda () stmt stmt* ...)))
 182
 183 (define-syntax-rule (without-shellopts (opt opt* ...) stmt stmt* ...)
 184   (call-without-shellopts '(opt opt* ...) (lambda () stmt stmt* ...)))
 185
 186 (export call-with-shellopts call-without-shellopts)
 187 (export with-shellopts without-shellopts)
 188
 189 ;; Safe version of `unsafe-evalstring`.
 190 (define (bash-eval str)
 191   (without-shellopts (errexit)
 192     (unsafe-evalstring str "(gnu bash)" '(nohist))))
 193
 194 (define-ffi-mask variable-flags:
 195   ((exported    #x0000001)      ; export to environment
 196    (readonly    #x0000002)      ; cannot change
 197    (array       #x0000004)      ; value is an array
 198    (function    #x0000008)      ; value is a function
 199    (integer     #x0000010)      ; internal representation is int
 200    (local       #x0000020)      ; variable is local to a function
 201    (assoc       #x0000040)      ; variable is an associative array
 202    (trace       #x0000080)      ; function is traced with DEBUG trap
 203    (uppercase   #x0000100)      ; word converted to uppercase on assignment
 204    (lowercase   #x0000200)      ; word converted to lowercase on assignment
 205    (capcase     #x0000400)      ; word capitalized on assignment
 206    (nameref     #x0000800)      ; word is a name reference
 207    (invisible   #x0001000)      ; cannot see
 208    (nounset     #x0002000)      ; cannot unset
 209    (noassign    #x0004000)      ; assignment not allowed
 210    (imported    #x0008000)      ; came from environment
 211    (special     #x0010000)      ; requires special handling
 212    (nofree      #x0020000)      ; do not free value on unset
 213    (tempvar     #x0100000)      ; variable came from the temp environment
 214    (propagate   #x0200000)))    ; propagate to previous scope
 215
 216 (define-ffi-struct variable:
 217   ((string: name)
 218    (?string: value)
 219    ;; This field isn't used, so why waste effort on decoding it?
 220    (*: exportstr)
 221    ;; These two fields are very delicate and worth several days of
 222    ;; segfault debugging with no output, so they are handled in C.
 223    (*: dynamic-value)
 224    (*: assign-func)
 225    (variable-flags: attributes)
 226    (int: context)))
 227
 228 (define-ffi get-string-value ((#:const string: var-name) -> ?string:))
 229 (define-ffi find-variable ((#:const string: name) -> ?variable:))
 230 (define-ffi bind-variable
 231   ((#:const string: name) (#:const string: value) (variable-flags: flags)
 232     -> variable:))
 233 (define-ffi bind-global-variable
 234   ((#:const string: name) (#:const string: value) (variable-flags: flags)
 235    -> variable:))
 236 (define-ffi quote-escapes ((#:const string: str) -> #:alloc string:))
 237 (define (show x)
 238   (format #f "~a" x))
 239 (define quote-show (compose quote-escapes show))
 240
 241 (define (args->eval-string args)
 242   (string-join (map quote-show args) " "))
 243
 244 (define (eval-args args)
 245   (bash-eval (args->eval-string args)))
 246
 247 (define (capture-output args)
 248   (define eval-str (args->eval-string args))
 249   (bash-eval (format #f "SCM_OUTPUT=$(~a)" eval-str))
 250   (unless (zero? (last-command-exit-value))
 251     (error 'bash-command-error eval-str (last-command-exit-value)))
 252   (get-string-value "SCM_OUTPUT"))
 253
 254 (define ($-hash-reader _unused port)
 255   (define (skip-chars pred port)
 256     (define current-char (read-char port))
 257     (when (eof-object? current-char)
 258       (error 'read-error 'premature-EOF))
 259     (if (pred current-char)
 260         (skip-chars pred port)
 261       current-char))
 262   (define char-after (skip-chars char-whitespace? port))
 263   (case char-after
 264     ((#\?) '((@@ (gnu bash) last-command-exit-value)))
 265     (else
 266      (unread-char char-after port)
 267      (let ((sexp (read port)))
 268        (case char-after
 269          ((#\") `((@@ (gnu bash) bash-eval) ,sexp))
 270          ((#\[)  (list '(@@ (gnu bash) eval-args)
 271                        (list 'quasiquote sexp)))
 272          ((#\()  (list '(@@ (gnu bash) capture-output)
 273                        (list 'quasiquote sexp)))
 274          (else (list '(@@ (gnu bash) $) (list 'quote sexp))))))))
 275
 276 (read-hash-extend #\$ $-hash-reader)
 277
 278 (define ($-ref name)
 279   (get-string-value (show name)))
 280
 281 (define ($-set name value)
 282   (bind-variable (show name) (show value) '()))
 283
 284 (define-public $ (make-procedure-with-setter $-ref $-set))
 285
 286 (define-public bind-scm-function
 287   (let ()
 288     (define *funcs* (make-hash-table))
 289     (define special-varname 'SCM_FUNCTIONS_MAGIC_VARIABLE)
 290     (define (special-var-thunk)
 291       (define cur-func-symbol (string->symbol ($ 'FUNCNAME)))
 292       (define thunk (hashq-ref *funcs* cur-func-symbol))
 293       (catch #t
 294         (lambda ()
 295           (define retval (thunk))
 296           (if (integer? retval)
 297               (format #f "~a" retval)
 298             "0"))
 299         (lambda (key . args)
 300           (print-exception (current-error-port) #f key args)
 301           "41")))
 302
 303     (bind-dynamic-variable special-varname special-var-thunk)
 304     ;; Problem is that in dynamic variable handler I have no access to
 305     ;; dollar variables. Quick and dirty solution is just save $@ into
 306     ;; some other array. Yeah, global variables are evil, but it saves
 307     ;; load of code to maintain and debug.
 308     (lambda (symbol thunk)
 309       (hashq-set! *funcs* symbol thunk)
 310       (unsafe-format/eval
 311        "function ~a {
 312             SCM_ARGS=($@)    ;
 313             local retval=$~a ;
 314             unset SCM_ARGS   ;
 315             return $retval   ;
 316        }"
 317        symbol special-varname))))
 318
 319 (export define-bash-function)
 320 (define-syntax-rule (define-bash-function (fn-name arg ...) stmt stmt* ...)
 321   (begin
 322     (define (fn-name arg ...)
 323       stmt stmt* ...)
 324     (bind-scm-function
 325      'fn-name
 326      (lambda ()
 327        (define bash-args (map cdr (array->alist 'SCM_ARGS)))
 328        (match bash-args
 329          ((arg ...) (fn-name arg ...))
 330          (_ (scm-error
 331              'wrong-number-of-args
 332              (symbol->string 'fn-name)
 333              "scm-function called from Bash with args ~A failed to match signature ~A"
 334              (list bash-args '(arg ...))
 335              #f)))))))