From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Neil Jerram Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 4/5] Implement #:stop-at-first-non-option option for getopt-long Date: Sun, 8 May 2011 23:18:16 +0100 Message-ID: <1304893097-10889-5-git-send-email-neil@ossau.uklinux.net> References: <1304893097-10889-1-git-send-email-neil@ossau.uklinux.net> NNTP-Posting-Host: lo.gmane.org X-Trace: dough.gmane.org 1304893194 27080 80.91.229.12 (8 May 2011 22:19:54 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sun, 8 May 2011 22:19:54 +0000 (UTC) Cc: Neil Jerram To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon May 09 00:19:50 2011 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([140.186.70.17]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1QJCKL-0003rg-AS for guile-devel@m.gmane.org; Mon, 09 May 2011 00:19:49 +0200 Original-Received: from localhost ([::1]:37404 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJCKK-0000i1-Mz for guile-devel@m.gmane.org; Sun, 08 May 2011 18:19:48 -0400 Original-Received: from eggs.gnu.org ([140.186.70.92]:42082) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJCKF-0000gs-1D for guile-devel@gnu.org; Sun, 08 May 2011 18:19:44 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1QJCKD-0002rm-2F for guile-devel@gnu.org; Sun, 08 May 2011 18:19:42 -0400 Original-Received: from mail3.uklinux.net ([80.84.72.33]:52020) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJCKC-0002mp-P3 for guile-devel@gnu.org; Sun, 08 May 2011 18:19:41 -0400 Original-Received: from arudy (unknown [78.149.196.143]) by mail3.uklinux.net (Postfix) with ESMTP id 7610C1F66A7 for ; Sun, 8 May 2011 23:18:54 +0100 (BST) Original-Received: from neil-laptop.520b.com (unknown [192.168.11.9]) by arudy (Postfix) with ESMTP id 9D49F3803C; Sun, 8 May 2011 23:18:48 +0100 (BST) X-Mailer: git-send-email 1.7.4.1 In-Reply-To: <1304893097-10889-1-git-send-email-neil@ossau.uklinux.net> X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.4-2.6 X-Received-From: 80.84.72.33 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:12467 Archived-At: (For use by guile-tools) * module/ice-9/getopt-long.scm: Use (ice-9 optargs) so we can use define*. (process-options): Add stop-at-first-non-option parameter. When this is true, stop processing when we hit a non-option (so long as that non-option isn't something that resulted from the unclumping of a short option group). (getopt-long): Add #:stop-at-first-non-option keyword; pass it on to process-options. * test-suite/tests/getopt-long.test ("stop-at-first-non-option"): New test (for the above). --- module/ice-9/getopt-long.scm | 12 +++++++++--- test-suite/tests/getopt-long.test | 11 +++++++++++ 2 files changed, 20 insertions(+), 3 deletions(-) diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm index 0c2d835..12f8c94 100644 --- a/module/ice-9/getopt-long.scm +++ b/module/ice-9/getopt-long.scm @@ -161,6 +161,7 @@ #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 optargs) #:export (getopt-long option-ref)) (define %program-name (make-fluid)) @@ -231,7 +232,7 @@ (regexp-exec long-opt-with-value-rx string) (regexp-exec long-opt-no-value-rx string))) -(define (process-options specs argument-ls) +(define (process-options specs argument-ls stop-at-first-non-option) ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC). ;; FOUND is an unordered list of option specs for found options, while ETC ;; is an order-maintained list of elements in ARGUMENT-LS that are neither @@ -300,10 +301,14 @@ (eat! spec (cons (match:substring match 2) rest)) (fatal-error "option does not support argument: --~a" opt))))) + ((and stop-at-first-non-option + (<= unclumped 0)) + (cons found (append (reverse etc) argument-ls))) (else (loop (- unclumped 1) rest found (cons opt etc))))))))) -(define (getopt-long program-arguments option-desc-list) +(define* (getopt-long program-arguments option-desc-list + #:key stop-at-first-non-option) "Process options, handling both long and short options, similar to the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value similar to what (program-arguments) returns. OPTION-DESC-LIST is a @@ -339,7 +344,8 @@ to add a `single-char' clause to the option description." (pair (split-arg-list (cdr program-arguments))) (split-ls (car pair)) (non-split-ls (cdr pair)) - (found/etc (process-options specifications split-ls)) + (found/etc (process-options specifications split-ls + stop-at-first-non-option)) (found (car found/etc)) (rest-ls (append (cdr found/etc) non-split-ls))) (for-each (lambda (spec) diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test index 682763c..4ae6048 100644 --- a/test-suite/tests/getopt-long.test +++ b/test-suite/tests/getopt-long.test @@ -288,4 +288,15 @@ ) +(with-test-prefix "stop-at-first-non-option" + + (pass-if "guile-tools compile example" + (equal? (getopt-long '("guile-tools" "compile" "-Wformat" "eval.scm" "-o" "eval.go") + '((help (single-char #\h)) + (version (single-char #\v))) + #:stop-at-first-non-option #t) + '((() "compile" "-Wformat" "eval.scm" "-o" "eval.go")))) + + ) + ;;; getopt-long.test ends here -- 1.7.4.1