;;; srfi-37.scm - Argument option processor ; ; Copyright (c) 2002 Anthony Carrico ; ; All rights reserved. ; ; - ported to Chicken by felix (module srfi-37 (option option? option-names option-required-arg? option-optional-arg? option-processor args-fold) (import scheme (chicken base)) (define-record-type srfi-37:option (option names required-arg? optional-arg? processor) option? (names option-names) (required-arg? option-required-arg?) (optional-arg? option-optional-arg?) (processor option-processor)) (define args-fold (lambda (args ; list of args options ; list of options unrecognized-option-proc ;; (lambda (non-option . seeds) ) -> next-seed ... non-option-proc . seeds) (letrec ((find (lambda (l ?) (cond ((null? l) #f) ((? (car l)) (car l)) (else (find (cdr l) ?))))) (find-option ;; ISSUE: This is a brute force search. Could use a table. (lambda (name) (find options (lambda (option) (find (option-names option) (lambda (test-name) (equal? name test-name))))))) (scan-short-options (lambda (index shorts args seeds) (if (= index (string-length shorts)) (scan-args args seeds) (let* ((name (string-ref shorts index)) (option (or (find-option name) (option (list name) #f #f unrecognized-option-proc)))) (cond ((and (< (+ index 1) (string-length shorts)) (or (option-required-arg? option) (option-optional-arg? option))) (receive seeds (apply (option-processor option) option name (substring shorts (+ index 1) (string-length shorts)) seeds) (scan-args args seeds))) ((and (option-required-arg? option) (pair? args)) (receive seeds (apply (option-processor option) option name (car args) seeds) (scan-args (cdr args) seeds))) (else (receive seeds (apply (option-processor option) option name #f seeds) (scan-short-options (+ index 1) shorts args seeds)))))))) (scan-non-options (lambda (non-options seeds) (if (null? non-options) (apply values seeds) (receive seeds (apply non-option-proc (car non-options) seeds) (scan-non-options (cdr non-options) seeds))))) (parse-long-option ;; "--([^=]+)=(.*)" (lambda (str len) (let loop ([i 2]) (cond [(>= i len) #f] [(char=? #\= (string-ref str i)) (cons (substring str 2 i) (substring str (add1 i) len)) ] [else (loop (add1 i))] ) ) ) ) (scan-args (lambda (args seeds) (if (null? args) (apply values seeds) (let* ([arg (car args)] [args (cdr args)] [len (string-length arg)] ) (if (and (> len 1) (char=? #\- (string-ref arg 0))) (if (char=? #\- (string-ref arg 1)) (cond [(eq? 2 len) (scan-non-options args seeds) ] [(parse-long-option arg len) => (lambda (name+arg) ;; Found long option with arg: (let* ([name (car name+arg)] [arg (cdr name+arg)] [option (or (find-option name) (option (list name) #t #f unrecognized-option-proc)) ] ) (receive seeds (apply (option-processor option) option name arg seeds) (scan-args args seeds) ) ) ) ] [else ;; Found long option: (let* ([name (substring arg 2 len)] [option (or (find-option name) (option (list name) #f #f unrecognized-option-proc)) ] ) (if (and (option-required-arg? option) (pair? args)) (receive seeds (apply (option-processor option) option name (car args) seeds) (scan-args (cdr args) seeds)) (receive seeds (apply (option-processor option) option name #f seeds) (scan-args args seeds)))) ] ) ;; Found short options (scan-short-options 0 (substring arg 1 len) args seeds) ) (receive seeds (apply non-option-proc arg seeds) (scan-args args seeds) ) ) ) ) ) ) ) (scan-args args seeds)))) )