123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230 |
- (define-module (ice-9 regex)
- #:export (match:count match:string match:prefix match:suffix
- regexp-match? regexp-quote match:start match:end match:substring
- string-match regexp-substitute fold-matches list-matches
- regexp-substitute/global))
- (define (match:count match)
- (- (vector-length match) 1))
- (define (match:string match)
- (vector-ref match 0))
- (define (match:prefix match)
- (substring (match:string match) 0 (match:start match 0)))
- (define (match:suffix match)
- (substring (match:string match) (match:end match 0)))
- (define (regexp-match? match)
- (and (vector? match)
- (string? (vector-ref match 0))
- (let loop ((i 1))
- (cond ((>= i (vector-length match)) #t)
- ((and (pair? (vector-ref match i))
- (integer? (car (vector-ref match i)))
- (integer? (cdr (vector-ref match i))))
- (loop (+ 1 i)))
- (else #f)))))
- (define (regexp-quote string)
- (call-with-output-string
- (lambda (p)
- (string-for-each (lambda (c)
- (case c
- ((#\* #\. #\\ #\^ #\$ #\[)
- (write-char #\\ p)
- (write-char c p))
- ((#\( #\) #\+ #\? #\{ #\} #\|)
- (write-char #\[ p)
- (write-char c p)
- (write-char #\] p))
- (else
- (write-char c p))))
- string))))
- (define* (match:start match #:optional (n 0))
- (let ((start (car (vector-ref match (1+ n)))))
- (if (= start -1) #f start)))
- (define* (match:end match #:optional (n 0))
- (let* ((end (cdr (vector-ref match (1+ n)))))
- (if (= end -1) #f end)))
- (define* (match:substring match #:optional (n 0))
- (let* ((start (match:start match n))
- (end (match:end match n)))
- (and start end (substring (match:string match) start end))))
- (define (string-match pattern str . args)
- (let ((rx (make-regexp pattern))
- (start (if (pair? args) (car args) 0)))
- (regexp-exec rx str start)))
- (define (regexp-substitute port match . items)
-
- (if (not port)
- (call-with-output-string
- (lambda (p)
- (apply regexp-substitute p match items)))
-
- (for-each (lambda (obj)
- (cond ((string? obj) (display obj port))
- ((integer? obj) (display (match:substring match obj) port))
- ((eq? 'pre obj) (display (match:prefix match) port))
- ((eq? 'post obj) (display (match:suffix match) port))
- (else (error 'wrong-type-arg obj))))
- items)))
- (define* (fold-matches regexp string init proc #:optional (flags 0))
- (let ((regexp (if (regexp? regexp) regexp (make-regexp regexp))))
- (let loop ((start 0)
- (value init)
- (abuts #f))
- (define bol (if (zero? start) 0 regexp/notbol))
- (let ((m (if (> start (string-length string)) #f
- (regexp-exec regexp string start (logior flags bol)))))
- (cond
- ((not m) value)
- ((and (= (match:start m) (match:end m)) abuts)
-
-
-
- (loop (+ start 1) value #f))
- (else
- (loop (match:end m) (proc m value) #t)))))))
- (define* (list-matches regexp string #:optional (flags 0))
- (reverse! (fold-matches regexp string '() cons flags)))
- (define (regexp-substitute/global port regexp string . items)
-
- (if (not port)
- (call-with-output-string
- (lambda (p)
- (apply regexp-substitute/global p regexp string items)))
-
- (let next-match ((matches (list-matches regexp string))
- (start 0))
- (if (null? matches)
- (display (substring string start) port)
- (let ((m (car matches)))
-
-
-
- (let next-item ((items items))
- (define (do-item item)
- (cond
- ((string? item) (display item port))
- ((integer? item) (display (match:substring m item) port))
- ((procedure? item) (display (item m) port))
- ((eq? item 'pre)
- (display
- (substring string start (match:start m))
- port))
- ((eq? item 'post)
- (next-match (cdr matches) (match:end m)))
- (else (error 'wrong-type-arg item))))
- (if (pair? items)
- (if (null? (cdr items))
- (do-item (car items))
- (begin
- (do-item (car items))
- (next-item (cdr items)))))))))))
|