home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / guile / 1.6 / ice-9 / regex.scm < prev    next >
Encoding:
Text File  |  2006-06-19  |  9.5 KB  |  266 lines
  1. ;;;;     Copyright (C) 1997, 1999, 2001, 2004 Free Software Foundation, Inc.
  2. ;;;;
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;;
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;;
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16. ;;;; Boston, MA 02110-1301 USA
  17. ;;;;
  18. ;;;; As a special exception, the Free Software Foundation gives permission
  19. ;;;; for additional uses of the text contained in its release of GUILE.
  20. ;;;;
  21. ;;;; The exception is that, if you link the GUILE library with other files
  22. ;;;; to produce an executable, this does not by itself cause the
  23. ;;;; resulting executable to be covered by the GNU General Public License.
  24. ;;;; Your use of that executable is in no way restricted on account of
  25. ;;;; linking the GUILE library code into it.
  26. ;;;;
  27. ;;;; This exception does not however invalidate any other reasons why
  28. ;;;; the executable file might be covered by the GNU General Public License.
  29. ;;;;
  30. ;;;; This exception applies only to the code released by the
  31. ;;;; Free Software Foundation under the name GUILE.  If you copy
  32. ;;;; code from other Free Software Foundation releases into a copy of
  33. ;;;; GUILE, as the General Public License permits, the exception does
  34. ;;;; not apply to the code that you add in this way.  To avoid misleading
  35. ;;;; anyone as to the status of such modified files, you must delete
  36. ;;;; this exception notice from them.
  37. ;;;;
  38. ;;;; If you write modifications of your own for GUILE, it is your choice
  39. ;;;; whether to permit this exception to apply to your modifications.
  40. ;;;; If you do not wish that, delete this exception notice.
  41. ;;;;
  42.  
  43. ;;; Commentary:
  44.  
  45. ;; These procedures are exported:
  46. ;;  (match:count match)
  47. ;;  (match:string match)
  48. ;;  (match:prefix match)
  49. ;;  (match:suffix match)
  50. ;;  (regexp-match? match)
  51. ;;  (regexp-quote string)
  52. ;;  (match:start match . submatch-num)
  53. ;;  (match:end match . submatch-num)
  54. ;;  (match:substring match . submatch-num)
  55. ;;  (string-match pattern str . start)
  56. ;;  (regexp-substitute port match . items)
  57. ;;  (fold-matches regexp string init proc . flags)
  58. ;;  (list-matches regexp string . flags)
  59. ;;  (regexp-substitute/global port regexp string . items)
  60.  
  61. ;;; Code:
  62.  
  63. ;;;; POSIX regex support functions.
  64.  
  65. (define-module (ice-9 regex)
  66.   :export (match:count match:string match:prefix match:suffix
  67.        regexp-match? regexp-quote match:start match:end match:substring
  68.        string-match regexp-substitute fold-matches list-matches
  69.        regexp-substitute/global))
  70.  
  71. ;; References:
  72. ;;
  73. ;; POSIX spec:
  74. ;; http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap09.html
  75.  
  76. ;;; FIXME:
  77. ;;;   It is not clear what should happen if a `match' function
  78. ;;;   is passed a `match number' which is out of bounds for the
  79. ;;;   regexp match: return #f, or throw an error?  These routines
  80. ;;;   throw an out-of-range error.
  81.  
  82. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83. ;;;; These procedures are not defined in SCSH, but I found them useful.
  84.  
  85. (define (match:count match)
  86.   (- (vector-length match) 1))
  87.  
  88. (define (match:string match)
  89.   (vector-ref match 0))
  90.  
  91. (define (match:prefix match)
  92.   (substring (match:string match) 0 (match:start match 0)))
  93.  
  94. (define (match:suffix match)
  95.   (substring (match:string match) (match:end match 0)))
  96.  
  97. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98. ;;;; SCSH compatibility routines.
  99.  
  100. (define (regexp-match? match)
  101.   (and (vector? match)
  102.        (string? (vector-ref match 0))
  103.        (let loop ((i 1))
  104.      (cond ((>= i (vector-length match)) #t)
  105.            ((and (pair? (vector-ref match i))
  106.              (integer? (car (vector-ref match i)))
  107.              (integer? (cdr (vector-ref match i))))
  108.         (loop (+ 1 i)))
  109.            (else #f)))))
  110.  
  111. ;; * . \ ^ $ and [ are special in both regexp/basic and regexp/extended and
  112. ;; can be backslash escaped.
  113. ;;
  114. ;; ( ) + ? { } and | are special in regexp/extended so must be quoted.  But
  115. ;; that can't be done with a backslash since in regexp/basic where they're
  116. ;; not special, adding a backslash makes them become special.  Character
  117. ;; class forms [(] etc are used instead.
  118. ;;
  119. ;; ) is not special when not preceded by a (, and * and ? are not special at
  120. ;; the start of a string, but we quote all of these always, so the result
  121. ;; can be concatenated or merged into some larger regexp.
  122. ;;
  123. ;; ] is not special outside a [ ] character class, so doesn't need to be
  124. ;; quoted.
  125. ;;
  126. (define (regexp-quote string)
  127.   (call-with-output-string
  128.    (lambda (p)
  129.      (let loop ((i 0))
  130.        (and (< i (string-length string))
  131.         (begin
  132.           (case (string-ref string i)
  133.         ((#\* #\. #\\ #\^ #\$ #\[)
  134.          (write-char #\\ p)
  135.          (write-char (string-ref string i) p))
  136.         ((#\( #\) #\+ #\? #\{ #\} #\|)
  137.          (write-char #\[ p)
  138.          (write-char (string-ref string i) p)
  139.          (write-char #\] p))
  140.         (else
  141.          (write-char (string-ref string i) p)))
  142.           (loop (1+ i))))))))
  143.  
  144. (define (match:start match . args)
  145.   (let* ((matchnum (if (pair? args)
  146.                (+ 1 (car args))
  147.                1))
  148.      (start (car (vector-ref match matchnum))))
  149.     (if (= start -1) #f start)))
  150.  
  151. (define (match:end match . args)
  152.   (let* ((matchnum (if (pair? args)
  153.                (+ 1 (car args))
  154.                1))
  155.      (end (cdr (vector-ref match matchnum))))
  156.     (if (= end -1) #f end)))
  157.  
  158. (define (match:substring match . args)
  159.   (let* ((matchnum (if (pair? args)
  160.                (car args)
  161.                0))
  162.      (start (match:start match matchnum))
  163.      (end   (match:end match matchnum)))
  164.     (and start end (substring (match:string match) start end))))
  165.  
  166. (define (string-match pattern str . args)
  167.   (let ((rx (make-regexp pattern))
  168.     (start (if (pair? args) (car args) 0)))
  169.     (regexp-exec rx str start)))
  170.  
  171. (define (regexp-substitute port match . items)
  172.   ;; If `port' is #f, send output to a string.
  173.   (if (not port)
  174.       (call-with-output-string
  175.        (lambda (p)
  176.      (apply regexp-substitute p match items)))
  177.  
  178.       ;; Otherwise, process each substitution argument in `items'.
  179.       (for-each (lambda (obj)
  180.           (cond ((string? obj)   (display obj port))
  181.             ((integer? obj)  (display (match:substring match obj) port))
  182.             ((eq? 'pre obj)  (display (match:prefix match) port))
  183.             ((eq? 'post obj) (display (match:suffix match) port))
  184.             (else (error 'wrong-type-arg obj))))
  185.         items)))
  186.  
  187. ;;; If we call fold-matches, below, with a regexp that can match the
  188. ;;; empty string, it's not obvious what "all the matches" means.  How
  189. ;;; many empty strings are there in the string "a"?  Our answer:
  190. ;;;
  191. ;;;     This function applies PROC to every non-overlapping, maximal
  192. ;;;     match of REGEXP in STRING.
  193. ;;;
  194. ;;; "non-overlapping": There are two non-overlapping matches of "" in
  195. ;;; "a" --- one before the `a', and one after.  There are three
  196. ;;; non-overlapping matches of "q|x*" in "aqb": the empty strings
  197. ;;; before `a' and after `b', and `q'.  The two empty strings before
  198. ;;; and after `q' don't count, because they overlap with the match of
  199. ;;; "q".
  200. ;;;
  201. ;;; "maximal": There are three distinct maximal matches of "x*" in
  202. ;;; "axxxb": one before the `a', one covering `xxx', and one after the
  203. ;;; `b'.  Around or within `xxx', only the match covering all three
  204. ;;; x's counts, because the rest are not maximal.
  205.  
  206. (define (fold-matches regexp string init proc . flags)
  207.   (let ((regexp (if (regexp? regexp) regexp (make-regexp regexp)))
  208.     (flags (if (null? flags) 0 flags)))
  209.     (let loop ((start 0)
  210.            (value init)
  211.            (abuts #f))        ; True if start abuts a previous match.
  212.       (let ((m (if (> start (string-length string)) #f
  213.            (regexp-exec regexp string start flags))))
  214.     (cond
  215.      ((not m) value)
  216.      ((and (= (match:start m) (match:end m)) abuts)
  217.       ;; We matched an empty string, but that would overlap the
  218.       ;; match immediately before.  Try again at a position
  219.       ;; further to the right.
  220.       (loop (+ start 1) value #f))
  221.      (else
  222.       (loop (match:end m) (proc m value) #t)))))))
  223.  
  224. (define (list-matches regexp string . flags)
  225.   (reverse! (apply fold-matches regexp string '() cons flags)))
  226.  
  227. (define (regexp-substitute/global port regexp string . items)
  228.  
  229.   ;; If `port' is #f, send output to a string.
  230.   (if (not port)
  231.       (call-with-output-string
  232.        (lambda (p)
  233.      (apply regexp-substitute/global p regexp string items)))
  234.  
  235.       ;; Walk the set of non-overlapping, maximal matches.
  236.       (let next-match ((matches (list-matches regexp string))
  237.                (start 0))
  238.     (if (null? matches)
  239.         (display (substring string start) port)
  240.         (let ((m (car matches)))
  241.  
  242.           ;; Process all of the items for this match.  Don't use
  243.           ;; for-each, because we need to make sure 'post at the
  244.           ;; end of the item list is a tail call.
  245.           (let next-item ((items items))
  246.  
  247.         (define (do-item item)
  248.           (cond
  249.            ((string? item)    (display item port))
  250.            ((integer? item)   (display (match:substring m item) port))
  251.            ((procedure? item) (display (item m) port))
  252.            ((eq? item 'pre)
  253.             (display
  254.              (substring string start (match:start m))
  255.              port))
  256.            ((eq? item 'post)
  257.             (next-match (cdr matches) (match:end m)))
  258.            (else (error 'wrong-type-arg item))))
  259.  
  260.         (if (pair? items)
  261.             (if (null? (cdr items))
  262.             (do-item (car items)) ; This is a tail call.
  263.             (begin
  264.               (do-item (car items)) ; This is not.
  265.               (next-item (cdr items)))))))))))
  266.