module/ice-9/command-line.scm

   1 ;;; Parsing Guile's command-line
   2
   3 ;;; Copyright (C) 1994-1998, 2000-2015 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 ;;;
  22 ;;; Please be careful not to load up other modules in this file, unless
  23 ;;; they are explicitly requested.  Loading modules currently imposes a
  24 ;;; speed penalty of a few stats, an mmap, and some allocation, which
  25 ;;; can range from 1 to 20ms, depending on the state of your disk cache.
  26 ;;; Since `compile-shell-switches' is called even for the most transient
  27 ;;; of command-line programs, we need to keep it lean.
  28 ;;;
  29 ;;; Generally speaking, the goal is for Guile to boot and execute simple
  30 ;;; expressions like "1" within 20ms or less, measured using system time
  31 ;;; from the time of the `guile' invocation to exit.
  32 ;;;
  33
  34 (define-module (ice-9 command-line)
  35   #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine!)
  36   #:export (compile-shell-switches
  37             version-etc
  38             *GPLv3+*
  39             *LGPLv3+*
  40             emit-bug-reporting-address))
  41
  42 ;; An initial stab at i18n.
  43 (define _ gettext)
  44
  45 (define *GPLv3+*
  46   (_ "License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>.
  47 This is free software: you are free to change and redistribute it.
  48 There is NO WARRANTY, to the extent permitted by law."))
  49
  50 (define *LGPLv3+*
  51   (_ "License LGPLv3+: GNU LGPL 3 or later <http://gnu.org/licenses/lgpl.html>.
  52 This is free software: you are free to change and redistribute it.
  53 There is NO WARRANTY, to the extent permitted by law."))
  54
  55 ;; Display the --version information in the
  56 ;; standard way: command and package names, package version, followed
  57 ;; by a short license notice and a list of up to 10 author names.
  58 ;; If COMMAND_NAME is NULL, the PACKAGE is asumed to be the name of
  59 ;; the program.  The formats are therefore:
  60 ;; PACKAGE VERSION
  61 ;; or
  62 ;; COMMAND_NAME (PACKAGE) VERSION.
  63 ;;
  64 ;; Based on the version-etc gnulib module.
  65 ;;
  66 (define* (version-etc package version #:key
  67                       (port (current-output-port))
  68                       ;; FIXME: authors
  69                       (copyright-year 2014)
  70                       (copyright-holder "Free Software Foundation, Inc.")
  71                       (copyright (format #f "Copyright (C) ~a ~a"
  72                                          copyright-year copyright-holder))
  73                       (license *GPLv3+*)
  74                       command-name
  75                       packager packager-version)
  76   (if command-name
  77       (format port "~a (~a) ~a\n" command-name package version)
  78       (format port "~a ~a\n" package version))
  79
  80   (if packager
  81       (if packager-version
  82           (format port (_ "Packaged by ~a (~a)\n") packager packager-version)
  83           (format port (_ "Packaged by ~a\n") packager)))
  84
  85   (display copyright port)
  86   (newline port)
  87   (newline port)
  88   (display license port)
  89   (newline port))
  90
  91
  92 ;; Display the usual `Report bugs to' stanza.
  93 ;;
  94 (define* (emit-bug-reporting-address package bug-address #:key
  95                                      (port (current-output-port))
  96                                      (url (string-append
  97                                            "http://www.gnu.org/software/"
  98                                            package
  99                                            "/"))
 100                                      packager packager-bug-address)
 101   (format port (_ "\nReport bugs to: ~a\n") bug-address)
 102   (if (and packager packager-bug-address)
 103       (format port (_ "Report ~a bugs to: ~a\n") packager packager-bug-address))
 104   (format port (_ "~a home page: <~a>\n") package url)
 105   (format port
 106           (_ "General help using GNU software: <http://www.gnu.org/gethelp/>\n")))
 107
 108 (define *usage*
 109   (_ "Evaluate code with Guile, interactively or from a script.
 110
 111   [-s] FILE      load source code from FILE, and exit
 112   -c EXPR        evalute expression EXPR, and exit
 113   --             stop scanning arguments; run interactively
 114
 115 The above switches stop argument processing, and pass all
 116 remaining arguments as the value of (command-line).
 117 If FILE begins with `-' the -s switch is mandatory.
 118
 119   -L DIRECTORY   add DIRECTORY to the front of the module load path
 120   -C DIRECTORY   like -L, but for compiled files
 121   -x EXTENSION   add EXTENSION to the front of the load extensions
 122   -l FILE        load source code from FILE
 123   -e FUNCTION    after reading script, apply FUNCTION to
 124                  command line arguments
 125   --language=LANG  change language; default: scheme
 126   -ds            do -s script at this point
 127   --debug        start with the \"debugging\" VM engine
 128   --no-debug     start with the normal VM engine (backtraces but
 129                  no breakpoints); default is --debug for interactive
 130                  use, but not for `-s' and `-c'.
 131   --auto-compile compile source files automatically
 132   --fresh-auto-compile  invalidate auto-compilation cache
 133   --no-auto-compile  disable automatic source file compilation;
 134                  default is to enable auto-compilation of source
 135                  files.
 136   --listen[=P]   listen on a local port or a path for REPL clients;
 137                  if P is not given, the default is local port 37146
 138   -q             inhibit loading of user init file
 139   --use-srfi=LS  load SRFI modules for the SRFIs in LS,
 140                  which is a list of numbers like \"2,13,14\"
 141   -h, --help     display this help and exit
 142   -v, --version  display version information and exit
 143   \\              read arguments from following script lines"))
 144
 145
 146 (define* (shell-usage name fatal? #:optional fmt . args)
 147   (let ((port (if fatal?
 148                   (current-error-port)
 149                   (current-output-port))))
 150     (when fmt
 151       (apply format port fmt args)
 152       (newline port))
 153
 154     (format port (_ "Usage: ~a [OPTION]... [FILE]...\n") name)
 155     (display *usage* port)
 156     (newline port)
 157
 158     (emit-bug-reporting-address
 159      "GNU Guile" "bug-guile@gnu.org"
 160      #:port port
 161      #:url "http://www.gnu.org/software/guile/"
 162      #:packager (assq-ref %guile-build-info 'packager)
 163      #:packager-bug-address
 164      (assq-ref %guile-build-info 'packager-bug-address))
 165
 166     (if fatal?
 167         (exit 1))))
 168
 169 ;; Try to avoid loading (ice-9 eval-string) and (system base compile) if
 170 ;; possible.
 171 (define (eval-string/lang str)
 172   (case (current-language)
 173     ((scheme)
 174      (call-with-input-string
 175       str
 176       (lambda (port)
 177         (let lp ()
 178           (let ((exp (read port)))
 179             (if (not (eof-object? exp))
 180                 (begin
 181                   (eval exp (current-module))
 182                   (lp))))))))
 183     (else
 184      ((module-ref (resolve-module '(ice-9 eval-string)) 'eval-string) str))))
 185
 186 (define (load/lang f)
 187   (case (current-language)
 188     ((scheme)
 189      (load-in-vicinity (getcwd) f))
 190     (else
 191      ((module-ref (resolve-module '(system base compile)) 'compile-file)
 192       f #:to 'value))))
 193
 194 (define* (compile-shell-switches args #:optional (usage-name "guile"))
 195   (let ((arg0 "guile")
 196         (script-cell #f)
 197         (entry-point #f)
 198         (user-load-path '())
 199         (user-load-compiled-path '())
 200         (user-extensions '())
 201         (interactive? #t)
 202         (inhibit-user-init? #f)
 203         (turn-on-debugging? #f)
 204         (turn-off-debugging? #f))
 205
 206     (define (error fmt . args)
 207       (apply shell-usage usage-name #t
 208              (string-append "error: " fmt "~%") args))
 209
 210     (define (parse args out)
 211       (cond
 212        ((null? args)
 213         (finish args out))
 214        (else
 215         (let ((arg (car args))
 216               (args (cdr args)))
 217           (cond
 218            ((not (string-prefix? "-" arg)) ; foo
 219             ;; If we specified the -ds option, script-cell is the cdr of
 220             ;; an expression like (load #f).  We replace the car (i.e.,
 221             ;; the #f) with the script name.
 222             (set! arg0 arg)
 223             (set! interactive? #f)
 224             (if script-cell
 225                 (begin
 226                   (set-car! script-cell arg0)
 227                   (finish args out))
 228                 (finish args
 229                         (cons `((@@ (ice-9 command-line) load/lang) ,arg0)
 230                               out))))
 231
 232            ((string=? arg "-s")         ; foo
 233             (if (null? args)
 234                 (error "missing argument to `-s' switch"))
 235             (set! arg0 (car args))
 236             (set! interactive? #f)
 237             (if script-cell
 238                 (begin
 239                   (set-car! script-cell arg0)
 240                   (finish (cdr args) out))
 241                 (finish (cdr args)
 242                         (cons `((@@ (ice-9 command-line) load/lang) ,arg0)
 243                               out))))
 244
 245            ((string=? arg "-c")         ; evaluate expr
 246             (if (null? args)
 247                 (error "missing argument to `-c' switch"))
 248             (set! interactive? #f)
 249             (finish (cdr args)
 250                     (cons `((@@ (ice-9 command-line) eval-string/lang)
 251                             ,(car args))
 252                           out)))
 253
 254            ((string=? arg "--")         ; end args go interactive
 255             (finish args out))
 256
 257            ((string=? arg "-l")         ; load a file
 258             (if (null? args)
 259                 (error "missing argument to `-l' switch"))
 260             (parse (cdr args)
 261                    (cons `((@@ (ice-9 command-line) load/lang) ,(car args))
 262                          out)))
 263
 264            ((string=? arg "-L")         ; add to %load-path
 265             (if (null? args)
 266                 (error "missing argument to `-L' switch"))
 267             (set! user-load-path (cons (car args) user-load-path))
 268             (parse (cdr args)
 269                    out))
 270
 271            ((string=? arg "-C")         ; add to %load-compiled-path
 272             (if (null? args)
 273                 (error "missing argument to `-C' switch"))
 274             (set! user-load-compiled-path
 275                   (cons (car args) user-load-compiled-path))
 276             (parse (cdr args)
 277                    out))
 278
 279            ((string=? arg "-x")         ; add to %load-extensions
 280             (if (null? args)
 281                 (error "missing argument to `-x' switch"))
 282             (set! user-extensions (cons (car args) user-extensions))
 283             (parse (cdr args)
 284                    out))
 285
 286            ((string=? arg "-e")         ; entry point
 287             (if (null? args)
 288                 (error "missing argument to `-e' switch"))
 289             (let* ((port (open-input-string (car args)))
 290                    (arg1 (read port))
 291                    (arg2 (read port)))
 292               ;; Recognize syntax of certain versions of guile 1.4 and
 293               ;; transform to (@ MODULE-NAME FUNC).
 294               (set! entry-point
 295                     (cond
 296                      ((not (eof-object? arg2))
 297                       `(@ ,arg1 ,arg2))
 298                      ((and (pair? arg1)
 299                            (not (memq (car arg1) '(@ @@)))
 300                            (and-map symbol? arg1))
 301                       `(@ ,arg1 main))
 302                      (else
 303                       arg1))))
 304             (parse (cdr args)
 305                    out))
 306
 307            ((string-prefix? "--language=" arg) ; language
 308             (parse args
 309                    (cons `(current-language
 310                            ',(string->symbol
 311                               (substring arg (string-length "--language="))))
 312                          out)))
 313
 314            ((string=? "--language" arg) ; language
 315             (when (null? args)
 316               (error "missing argument to `--language' option"))
 317             (parse (cdr args)
 318                    (cons `(current-language ',(string->symbol (car args)))
 319                          out)))
 320
 321            ((string=? arg "-ds")        ; do script here
 322             ;; We put a dummy "load" expression, and let the -s put the
 323             ;; filename in.
 324             (when script-cell
 325               (error "the -ds switch may only be specified once"))
 326             (set! script-cell (list #f))
 327             (parse args
 328                    (acons '(@@ (ice-9 command-line) load/lang)
 329                           script-cell
 330                           out)))
 331
 332            ((string=? arg "--debug")
 333             (set! turn-on-debugging? #t)
 334             (set! turn-off-debugging? #f)
 335             (parse args out))
 336
 337            ((string=? arg "--no-debug")
 338             (set! turn-off-debugging? #t)
 339             (set! turn-on-debugging? #f)
 340             (parse args out))
 341
 342            ;; Do auto-compile on/off now, because the form itself might
 343            ;; need this decision.
 344            ((string=? arg "--auto-compile")
 345             (set! %load-should-auto-compile #t)
 346             (parse args out))
 347
 348            ((string=? arg "--fresh-auto-compile")
 349             (set! %load-should-auto-compile #t)
 350             (set! %fresh-auto-compile #t)
 351             (parse args out))
 352
 353            ((string=? arg "--no-auto-compile")
 354             (set! %load-should-auto-compile #f)
 355             (parse args out))
 356
 357            ((string=? arg "-q")         ; don't load user init
 358             (set! inhibit-user-init? #t)
 359             (parse args out))
 360
 361            ((string-prefix? "--use-srfi=" arg)
 362             (let ((srfis (map (lambda (x)
 363                                 (let ((n (string->number x)))
 364                                   (if (and n (exact? n) (integer? n) (>= n 0))
 365                                       n
 366                                       (error "invalid SRFI specification"))))
 367                               (string-split (substring arg 11) #\,))))
 368               (if (null? srfis)
 369                   (error "invalid SRFI specification"))
 370               (parse args
 371                      (cons `(use-srfis ',srfis) out))))
 372
 373            ((string=? arg "--listen")   ; start a repl server
 374             (parse args
 375                    (cons '((@@ (system repl server) spawn-server)) out)))
 376
 377            ((string-prefix? "--listen=" arg) ; start a repl server
 378             (parse
 379              args
 380              (cons
 381               (let ((where (substring arg 9)))
 382                 (cond
 383                  ((string->number where) ; --listen=PORT
 384                   => (lambda (port)
 385                        (if (and (integer? port) (exact? port) (>= port 0))
 386                            `((@@ (system repl server) spawn-server)
 387                              ((@@ (system repl server) make-tcp-server-socket) #:port ,port))
 388                            (error "invalid port for --listen"))))
 389                  ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
 390                   `((@@ (system repl server) spawn-server)
 391                     ((@@ (system repl server) make-unix-domain-server-socket) #:path ,where)))
 392                  (else
 393                   (error "unknown argument to --listen"))))
 394               out)))
 395
 396            ((or (string=? arg "-h") (string=? arg "--help"))
 397             (shell-usage usage-name #f)
 398             (exit 0))
 399
 400            ((or (string=? arg "-v") (string=? arg "--version"))
 401             (version-etc "GNU Guile" (version)
 402                          #:license *LGPLv3+*
 403                          #:command-name "guile"
 404                          #:packager (assq-ref %guile-build-info 'packager)
 405                          #:packager-version
 406                          (assq-ref %guile-build-info 'packager-version))
 407             (exit 0))
 408
 409            (else
 410             (error "unrecognized switch ~a" arg)))))))
 411
 412     (define (finish args out)
 413       ;; Check to make sure the -ds got a -s.
 414       (when (and script-cell (not (car script-cell)))
 415         (error "the `-ds' switch requires the use of `-s' as well"))
 416
 417       ;; Make any remaining arguments available to the
 418       ;; script/command/whatever.
 419       (set-program-arguments (cons arg0 args))
 420
 421       ;; If debugging was requested, or we are interactive and debugging
 422       ;; was not explicitly turned off, use the debug engine.
 423       (if (or turn-on-debugging?
 424               (and interactive? (not turn-off-debugging?)))
 425           (begin
 426             (set-default-vm-engine! 'debug)
 427             (set-vm-engine! 'debug)))
 428
 429       ;; Return this value.
 430       `(;; It would be nice not to load up (ice-9 control), but the
 431         ;; default-prompt-handler is nontrivial.
 432         (@ (ice-9 control) %)
 433         (begin
 434           ;; If we didn't end with a -c or a -s and didn't supply a -q, load
 435           ;; the user's customization file.
 436           ,@(if (and interactive? (not inhibit-user-init?))
 437                 '((load-user-init))
 438                 '())
 439
 440           ;; Use-specified extensions.
 441           ,@(map (lambda (ext)
 442                    `(set! %load-extensions (cons ,ext %load-extensions)))
 443                  user-extensions)
 444
 445           ;; Add the user-specified load paths here, so they won't be in
 446           ;; effect during the loading of the user's customization file.
 447           ,@(map (lambda (path)
 448                    `(set! %load-path (cons ,path %load-path)))
 449                  user-load-path)
 450           ,@(map (lambda (path)
 451                    `(set! %load-compiled-path
 452                           (cons ,path %load-compiled-path)))
 453                  user-load-compiled-path)
 454
 455           ;; Put accumulated actions in their correct order.
 456           ,@(reverse! out)
 457
 458           ;; Handle the `-e' switch, if it was specified.
 459           ,@(if entry-point
 460                 `((,entry-point (command-line)))
 461                 '())
 462           ,(if interactive?
 463                ;; If we didn't end with a -c or a -s, start the
 464                ;; repl.
 465                '((@ (ice-9 top-repl) top-repl))
 466                ;; Otherwise, after doing all the other actions
 467                ;; prescribed by the command line, quit.
 468                '(quit)))))
 469
 470       (if (pair? args)
 471           (begin
 472             (set! arg0 (car args))
 473             (let ((slash (string-rindex arg0 #\/)))
 474               (set! usage-name
 475                     (if slash (substring arg0 (1+ slash)) arg0)))
 476             (parse (cdr args) '()))
 477           (parse args '()))))