module/ice-9/command-line.scm

   1 ;;; Parsing Guile's command-line
   2
   3 ;;; Copyright (C) 1994-1998, 2000-2011, 2012, 2013 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! the-vm)
  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 2013)
  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     (if fmt
 151         (apply format port fmt args))
 152
 153     (format port (_ "Usage: ~a [OPTION]... [FILE]...\n") name)
 154     (display *usage* port)
 155     (newline port)
 156
 157     (emit-bug-reporting-address
 158      "GNU Guile" "bug-guile@gnu.org"
 159      #:port port
 160      #:url "http://www.gnu.org/software/guile/"
 161      #:packager (assq-ref %guile-build-info 'packager)
 162      #:packager-bug-address
 163      (assq-ref %guile-build-info 'packager-bug-address))
 164
 165     (if fatal?
 166         (exit 1))))
 167
 168 ;; Try to avoid loading (ice-9 eval-string) and (system base compile) if
 169 ;; possible.
 170 (define (eval-string/lang str)
 171   (case (current-language)
 172     ((scheme)
 173      (call-with-input-string
 174       str
 175       (lambda (port)
 176         (let lp ()
 177           (let ((exp (read port)))
 178             (if (not (eof-object? exp))
 179                 (begin
 180                   (eval exp (current-module))
 181                   (lp))))))))
 182     (else
 183      ((module-ref (resolve-module '(ice-9 eval-string)) 'eval-string) str))))
 184
 185 (define (load/lang f)
 186   (case (current-language)
 187     ((scheme)
 188      (load-in-vicinity (getcwd) f))
 189     (else
 190      ((module-ref (resolve-module '(system base compile)) 'compile-file)
 191       f #:to 'value))))
 192
 193 (define* (compile-shell-switches args #:optional (usage-name "guile"))
 194   (let ((arg0 "guile")
 195         (script-cell #f)
 196         (entry-point #f)
 197         (user-load-path '())
 198         (user-load-compiled-path '())
 199         (user-extensions '())
 200         (interactive? #t)
 201         (inhibit-user-init? #f)
 202         (turn-on-debugging? #f)
 203         (turn-off-debugging? #f))
 204
 205     (define (error fmt . args)
 206       (apply shell-usage usage-name #t fmt args))
 207
 208     (define (parse args out)
 209       (cond
 210        ((null? args)
 211         (finish args out))
 212        (else
 213         (let ((arg (car args))
 214               (args (cdr args)))
 215           (cond
 216            ((not (string-prefix? "-" arg)) ; foo
 217             ;; If we specified the -ds option, script-cell is the cdr of
 218             ;; an expression like (load #f).  We replace the car (i.e.,
 219             ;; the #f) with the script name.
 220             (set! arg0 arg)
 221             (set! interactive? #f)
 222             (if script-cell
 223                 (begin
 224                   (set-car! script-cell arg0)
 225                   (finish args out))
 226                 (finish args
 227                         (cons `((@@ (ice-9 command-line) load/lang) ,arg0)
 228                               out))))
 229
 230            ((string=? arg "-s")         ; foo
 231             (if (null? args)
 232                 (error "missing argument to `-s' switch"))
 233             (set! arg0 (car args))
 234             (set! interactive? #f)
 235             (if script-cell
 236                 (begin
 237                   (set-car! script-cell arg0)
 238                   (finish (cdr args) out))
 239                 (finish (cdr args)
 240                         (cons `((@@ (ice-9 command-line) load/lang) ,arg0)
 241                               out))))
 242
 243            ((string=? arg "-c")         ; evaluate expr
 244             (if (null? args)
 245                 (error "missing argument to `-c' switch"))
 246             (set! interactive? #f)
 247             (finish (cdr args)
 248                     (cons `((@@ (ice-9 command-line) eval-string/lang)
 249                             ,(car args))
 250                           out)))
 251
 252            ((string=? arg "--")         ; end args go interactive
 253             (finish args out))
 254
 255            ((string=? arg "-l")         ; load a file
 256             (if (null? args)
 257                 (error "missing argument to `-l' switch"))
 258             (parse (cdr args)
 259                    (cons `((@@ (ice-9 command-line) load/lang) ,(car args))
 260                          out)))
 261
 262            ((string=? arg "-L")         ; add to %load-path
 263             (if (null? args)
 264                 (error "missing argument to `-L' switch"))
 265             (set! user-load-path (cons (car args) user-load-path))
 266             (parse (cdr args)
 267                    out))
 268
 269            ((string=? arg "-C")         ; add to %load-compiled-path
 270             (if (null? args)
 271                 (error "missing argument to `-C' switch"))
 272             (set! user-load-compiled-path
 273                   (cons (car args) user-load-compiled-path))
 274             (parse (cdr args)
 275                    out))
 276
 277            ((string=? arg "-x")         ; add to %load-extensions
 278             (if (null? args)
 279                 (error "missing argument to `-x' switch"))
 280             (set! user-extensions (cons (car args) user-extensions))
 281             (parse (cdr args)
 282                    out))
 283
 284            ((string=? arg "-e")         ; entry point
 285             (if (null? args)
 286                 (error "missing argument to `-e' switch"))
 287             (let* ((port (open-input-string (car args)))
 288                    (arg1 (read port))
 289                    (arg2 (read port)))
 290               ;; Recognize syntax of certain versions of guile 1.4 and
 291               ;; transform to (@ MODULE-NAME FUNC).
 292               (set! entry-point
 293                     (cond
 294                      ((not (eof-object? arg2))
 295                       `(@ ,arg1 ,arg2))
 296                      ((and (pair? arg1)
 297                            (not (memq (car arg1) '(@ @@)))
 298                            (and-map symbol? arg1))
 299                       `(@ ,arg1 main))
 300                      (else
 301                       arg1))))
 302             (parse (cdr args)
 303                    out))
 304
 305            ((string-prefix? "--language=" arg) ; language
 306             (parse args
 307                    (cons `(current-language
 308                            ',(string->symbol
 309                               (substring arg (string-length "--language="))))
 310                          out)))
 311
 312            ((string=? "--language" arg) ; language
 313             (when (null? args)
 314               (error "missing argument to `--language' option"))
 315             (parse (cdr args)
 316                    (cons `(current-language ',(string->symbol (car args)))
 317                          out)))
 318
 319            ((string=? arg "-ds")        ; do script here
 320             ;; We put a dummy "load" expression, and let the -s put the
 321             ;; filename in.
 322             (when script-cell
 323               (error "the -ds switch may only be specified once"))
 324             (set! script-cell (list #f))
 325             (parse args
 326                    (acons '(@@ (ice-9 command-line) load/lang)
 327                           script-cell
 328                           out)))
 329
 330            ((string=? arg "--debug")
 331             (set! turn-on-debugging? #t)
 332             (set! turn-off-debugging? #f)
 333             (parse args out))
 334
 335            ((string=? arg "--no-debug")
 336             (set! turn-off-debugging? #t)
 337             (set! turn-on-debugging? #f)
 338             (parse args out))
 339
 340            ;; Do auto-compile on/off now, because the form itself might
 341            ;; need this decision.
 342            ((string=? arg "--auto-compile")
 343             (set! %load-should-auto-compile #t)
 344             (parse args out))
 345
 346            ((string=? arg "--fresh-auto-compile")
 347             (set! %load-should-auto-compile #t)
 348             (set! %fresh-auto-compile #t)
 349             (parse args out))
 350
 351            ((string=? arg "--no-auto-compile")
 352             (set! %load-should-auto-compile #f)
 353             (parse args out))
 354
 355            ((string=? arg "-q")         ; don't load user init
 356             (set! inhibit-user-init? #t)
 357             (parse args out))
 358
 359            ((string-prefix? "--use-srfi=" arg)
 360             (let ((srfis (map (lambda (x)
 361                                 (let ((n (string->number x)))
 362                                   (if (and n (exact? n) (integer? n) (>= n 0))
 363                                       n
 364                                       (error "invalid SRFI specification"))))
 365                               (string-split (substring arg 11) #\,))))
 366               (if (null? srfis)
 367                   (error "invalid SRFI specification"))
 368               (parse args
 369                      (cons `(use-srfis ',srfis) out))))
 370
 371            ((string=? arg "--listen")   ; start a repl server
 372             (parse args
 373                    (cons '((@@ (system repl server) spawn-server)) out)))
 374
 375            ((string-prefix? "--listen=" arg) ; start a repl server
 376             (parse
 377              args
 378              (cons
 379               (let ((where (substring arg 9)))
 380                 (cond
 381                  ((string->number where) ; --listen=PORT
 382                   => (lambda (port)
 383                        (if (and (integer? port) (exact? port) (>= port 0))
 384                            `((@@ (system repl server) spawn-server)
 385                              ((@@ (system repl server) make-tcp-server-socket) #:port ,port))
 386                            (error "invalid port for --listen"))))
 387                  ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
 388                   `((@@ (system repl server) spawn-server)
 389                     ((@@ (system repl server) make-unix-domain-server-socket) #:path ,where)))
 390                  (else
 391                   (error "unknown argument to --listen"))))
 392               out)))
 393
 394            ((or (string=? arg "-h") (string=? arg "--help"))
 395             (shell-usage usage-name #f)
 396             (exit 0))
 397
 398            ((or (string=? arg "-v") (string=? arg "--version"))
 399             (version-etc "GNU Guile" (version)
 400                          #:license *LGPLv3+*
 401                          #:command-name "guile"
 402                          #:packager (assq-ref %guile-build-info 'packager)
 403                          #:packager-version
 404                          (assq-ref %guile-build-info 'packager-version))
 405             (exit 0))
 406
 407            (else
 408             (error "Unrecognized switch ~a" arg)))))))
 409
 410     (define (finish args out)
 411       ;; Check to make sure the -ds got a -s.
 412       (when (and script-cell (not (car script-cell)))
 413         (error "the `-ds' switch requires the use of `-s' as well"))
 414
 415       ;; Make any remaining arguments available to the
 416       ;; script/command/whatever.
 417       (set-program-arguments (cons arg0 args))
 418
 419       ;; If debugging was requested, or we are interactive and debugging
 420       ;; was not explicitly turned off, use the debug engine.
 421       (if (or turn-on-debugging?
 422               (and interactive? (not turn-off-debugging?)))
 423           (begin
 424             (set-default-vm-engine! 'debug)
 425             (set-vm-engine! (the-vm) 'debug)))
 426
 427       ;; Return this value.
 428       `(;; It would be nice not to load up (ice-9 control), but the
 429         ;; default-prompt-handler is nontrivial.
 430         (@ (ice-9 control) %)
 431         (begin
 432           ;; If we didn't end with a -c or a -s and didn't supply a -q, load
 433           ;; the user's customization file.
 434           ,@(if (and interactive? (not inhibit-user-init?))
 435                 '((load-user-init))
 436                 '())
 437
 438           ;; Use-specified extensions.
 439           ,@(map (lambda (ext)
 440                    `(set! %load-extensions (cons ,ext %load-extensions)))
 441                  user-extensions)
 442
 443           ;; Add the user-specified load paths here, so they won't be in
 444           ;; effect during the loading of the user's customization file.
 445           ,@(map (lambda (path)
 446                    `(set! %load-path (cons ,path %load-path)))
 447                  user-load-path)
 448           ,@(map (lambda (path)
 449                    `(set! %load-compiled-path
 450                           (cons ,path %load-compiled-path)))
 451                  user-load-compiled-path)
 452
 453           ;; Put accumulated actions in their correct order.
 454           ,@(reverse! out)
 455
 456           ;; Handle the `-e' switch, if it was specified.
 457           ,@(if entry-point
 458                 `((,entry-point (command-line)))
 459                 '())
 460           ,(if interactive?
 461                ;; If we didn't end with a -c or a -s, start the
 462                ;; repl.
 463                '((@ (ice-9 top-repl) top-repl))
 464                ;; Otherwise, after doing all the other actions
 465                ;; prescribed by the command line, quit.
 466                '(quit)))))
 467
 468       (if (pair? args)
 469           (begin
 470             (set! arg0 (car args))
 471             (let ((slash (string-rindex arg0 #\/)))
 472               (set! usage-name
 473                     (if slash (substring arg0 (1+ slash)) arg0)))
 474             (parse (cdr args) '()))
 475           (parse args '()))))