Component api

You are here: All Systems / cl-ppcre / api

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/api.lisp,v 1.71 2007/01/01 23:43:10 edi Exp $

;;; The external API for creating and using scanners.

;;; Copyright (c) 2002-2007, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(defgeneric create-scanner (regex &key case-insensitive-mode
                                       multi-line-mode
                                       single-line-mode
                                       extended-mode
                                       destructive)
  (:documentation "Accepts a regular expression - either as a
parse-tree or as a string - and returns a scan closure which will scan
strings for this regular expression. The \"mode\" keyboard arguments
are equivalent to the imsx modifiers in Perl. If DESTRUCTIVE is not
NIL the function is allowed to destructively modify its first argument
\(but only if it's a parse tree)."))

#-:use-acl-regexp2-engine
(defmethod create-scanner ((regex-string string) &key case-insensitive-mode
                                                      multi-line-mode
                                                      single-line-mode
                                                      extended-mode
                                                      destructive)
  (declare #.*standard-optimize-settings*)
  (declare (ignore destructive))
  ;; parse the string into a parse-tree and then call CREATE-SCANNER
  ;; again
  (let* ((*extended-mode-p* extended-mode)
         (quoted-regex-string (if *allow-quoting*
                                (quote-sections (clean-comments regex-string extended-mode))
                                regex-string))
         (*syntax-error-string* (copy-seq quoted-regex-string)))
    ;; wrap the result with :GROUP to avoid infinite loops for
    ;; constant strings
    (create-scanner (cons :group (list (parse-string quoted-regex-string)))
                    :case-insensitive-mode case-insensitive-mode
                    :multi-line-mode multi-line-mode
                    :single-line-mode single-line-mode
                    :destructive t)))

#-:use-acl-regexp2-engine
(defmethod create-scanner ((scanner function) &key case-insensitive-mode
                                                   multi-line-mode
                                                   single-line-mode
                                                   extended-mode
                                                   destructive)
  (declare #.*standard-optimize-settings*)
  (declare (ignore destructive))
  (when (or case-insensitive-mode multi-line-mode single-line-mode extended-mode)
    (signal-ppcre-invocation-error
     "You can't use the keyword arguments to modify an existing scanner."))
  scanner)

#-:use-acl-regexp2-engine
(defmethod create-scanner ((parse-tree t) &key case-insensitive-mode
                                               multi-line-mode
                                               single-line-mode
                                               extended-mode
                                               destructive)
  (declare #.*standard-optimize-settings*)
  (when extended-mode
    (signal-ppcre-invocation-error
     "Extended mode doesn't make sense in parse trees."))
  ;; convert parse-tree into internal representation REGEX and at the
  ;; same time compute the number of registers and the constant string
  ;; (or anchor) the regex starts with (if any)
  (unless destructive
    (setq parse-tree (copy-tree parse-tree)))
  (let (flags)
    (if single-line-mode
      (push :single-line-mode-p flags))
    (if multi-line-mode
      (push :multi-line-mode-p flags))
    (if case-insensitive-mode
      (push :case-insensitive-p flags))
    (when flags
      (setq parse-tree (list :group (cons :flags flags) parse-tree))))
  (let ((*syntax-error-string* nil))
    (multiple-value-bind (regex reg-num starts-with)
        (convert parse-tree)
      ;; simplify REGEX by flattening nested SEQ and ALTERNATION
      ;; constructs and gathering STR objects
      (let ((regex (gather-strings (flatten regex))))
        ;; set the MIN-REST slots of the REPETITION objects
        (compute-min-rest regex 0)
        ;; set the OFFSET slots of the STR objects
        (compute-offsets regex 0)
        (let* (end-string-offset
               end-anchored-p
               ;; compute the constant string the regex ends with (if
               ;; any) and at the same time set the special variables
               ;; END-STRING-OFFSET and END-ANCHORED-P
               (end-string (end-string regex))
               ;; if we found a non-zero-length end-string we create an
               ;; efficient search function for it
               (end-string-test (and end-string
                                     (plusp (len end-string))
                                     (if (= 1 (len end-string))
                                       (create-char-searcher
                                        (schar (str end-string) 0)
                                        (case-insensitive-p end-string))
                                       (create-bmh-matcher
                                        (str end-string)
                                        (case-insensitive-p end-string)))))
               ;; initialize the counters for CREATE-MATCHER-AUX
               (*rep-num* 0)
               (*zero-length-num* 0)
               ;; create the actual matcher function (which does all the
               ;; work of matching the regular expression) corresponding
               ;; to REGEX and at the same time set the special
               ;; variables *REP-NUM* and *ZERO-LENGTH-NUM*
               (match-fn (create-matcher-aux regex #'identity))
               ;; if the regex starts with a string we create an
               ;; efficient search function for it
               (start-string-test (and (typep starts-with 'str)
                                       (plusp (len starts-with))
                                       (if (= 1 (len starts-with))
                                         (create-char-searcher
                                          (schar (str starts-with) 0)
                                          (case-insensitive-p starts-with))
                                         (create-bmh-matcher
                                          (str starts-with)
                                          (case-insensitive-p starts-with))))))
          (declare (special end-string-offset end-anchored-p end-string))
          ;; now create the scanner and return it
          (create-scanner-aux match-fn
                              (regex-min-length regex)
                              (or (start-anchored-p regex)
                                  ;; a dot in single-line-mode also
                                  ;; implicitely anchors the regex at
                                  ;; the start, i.e. if we can't match
                                  ;; from the first position we won't
                                  ;; match at all
                                  (and (typep starts-with 'everything)
                                       (single-line-p starts-with)))
                              starts-with
                              start-string-test
                              ;; only mark regex as end-anchored if we
                              ;; found a non-zero-length string before
                              ;; the anchor
                              (and end-string-test end-anchored-p)
                              end-string-test
                              (if end-string-test
                                (len end-string)
                                nil)
                              end-string-offset
                              *rep-num*
                              *zero-length-num*
                              reg-num))))))

#+:use-acl-regexp2-engine
(declaim (inline create-scanner))

#+:use-acl-regexp2-engine
(defmethod create-scanner ((scanner regexp::regular-expression) &key case-insensitive-mode
                                                                     multi-line-mode
                                                                     single-line-mode
                                                                     extended-mode
                                                                     destructive)
  (declare #.*standard-optimize-settings*)
  (declare (ignore destructive))
  (when (or case-insensitive-mode multi-line-mode single-line-mode extended-mode)
    (signal-ppcre-invocation-error
     "You can't use the keyword arguments to modify an existing scanner."))
  scanner)

#+:use-acl-regexp2-engine
(defmethod create-scanner ((parse-tree t) &key case-insensitive-mode
                                               multi-line-mode
                                               single-line-mode
                                               extended-mode
                                               destructive)
  (declare #.*standard-optimize-settings*)
  (declare (ignore destructive))
  (excl:compile-re parse-tree
                   :case-fold case-insensitive-mode
                   :ignore-whitespace extended-mode
                   :multiple-lines multi-line-mode
                   :single-line single-line-mode
                   :return :index))

(defgeneric scan (regex target-string &key start end real-start-pos)
  (:documentation "Searches TARGET-STRING from START to END and tries
to match REGEX.  On success returns four values - the start of the
match, the end of the match, and two arrays denoting the beginnings
and ends of register matches.  On failure returns NIL.  REGEX can be a
string which will be parsed according to Perl syntax, a parse tree, or
a pre-compiled scanner created by CREATE-SCANNER.  TARGET-STRING will
be coerced to a simple string if it isn't one already.  The
REAL-START-POS parameter should be ignored - it exists only for
internal purposes."))

#-:use-acl-regexp2-engine
(defmethod scan ((regex-string string) target-string
                                       &key (start 0)
                                            (end (length target-string))
                                            ((:real-start-pos *real-start-pos*) nil))
  (declare #.*standard-optimize-settings*)
  ;; note that the scanners are optimized for simple strings so we
  ;; have to coerce TARGET-STRING into one if it isn't already
  (funcall (create-scanner regex-string)
           (maybe-coerce-to-simple-string target-string)
           start end))

#-:use-acl-regexp2-engine
(defmethod scan ((scanner function) target-string
                                    &key (start 0)
                                         (end (length target-string))
                                         ((:real-start-pos *real-start-pos*) nil))
  (declare #.*standard-optimize-settings*)
  (funcall scanner
           (maybe-coerce-to-simple-string target-string)
           start end))

#-:use-acl-regexp2-engine
(defmethod scan ((parse-tree t) target-string
                                &key (start 0)
                                     (end (length target-string))
                                     ((:real-start-pos *real-start-pos*) nil))
  (declare #.*standard-optimize-settings*)
  (funcall (create-scanner parse-tree)
           (maybe-coerce-to-simple-string target-string)
           start end))

#+:use-acl-regexp2-engine
(declaim (inline scan))

#+:use-acl-regexp2-engine
(defmethod scan ((parse-tree t) target-string
                                &key (start 0)
                                     (end (length target-string))
                                     ((:real-start-pos *real-start-pos*) nil))
  (declare #.*standard-optimize-settings*)
  (when (< end start)
    (return-from scan nil))
  (let ((results (multiple-value-list (excl:match-re parse-tree target-string
                                                     :start start
                                                     :end end
                                                     :return :index))))
    (declare (dynamic-extent results))
    (cond ((null (first results)) nil)
          (t (let* ((no-of-regs (- (length results) 2))
                    (reg-starts (make-array no-of-regs
                                            :element-type '(or null fixnum)))
                    (reg-ends (make-array no-of-regs
                                          :element-type '(or null fixnum)))
                    (match (second results)))
               (loop for (start . end) in (cddr results)
                     for i from 0
                     do (setf (aref reg-starts i) start
                              (aref reg-ends i) end))
               (values (car match) (cdr match) reg-starts reg-ends))))))

#-:cormanlisp
(define-compiler-macro scan (&whole form &environment env regex target-string &rest rest)
  "Make sure that constant forms are compiled into scanners at compile time."
  (cond ((constantp regex env)
          `(scan (load-time-value (create-scanner ,regex))
                 ,target-string ,@rest))
        (t form)))

(defun scan-to-strings (regex target-string &key (start 0)
                                                 (end (length target-string))
                                                 sharedp)
  (declare #.*standard-optimize-settings*)
  "Like SCAN but returns substrings of TARGET-STRING instead of
positions, i.e. this function returns two values on success: the whole
match as a string plus an array of substrings (or NILs) corresponding
to the matched registers. If SHAREDP is true, the substrings may share
structure with TARGET-STRING."
  (multiple-value-bind (match-start match-end reg-starts reg-ends)
      (scan regex target-string :start start :end end)
    (unless match-start
      (return-from scan-to-strings nil))
    (let ((substr-fn (if sharedp #'nsubseq #'subseq)))
      (values (funcall substr-fn
                       target-string match-start match-end)
              (map 'vector
                   (lambda (reg-start reg-end)
                     (if reg-start
                       (funcall substr-fn
                                target-string reg-start reg-end)
                       nil))
                   reg-starts
                   reg-ends)))))

#-:cormanlisp
(define-compiler-macro scan-to-strings
    (&whole form &environment env regex target-string &rest rest)
  "Make sure that constant forms are compiled into scanners at compile time."
  (cond ((constantp regex env)
          `(scan-to-strings (load-time-value (create-scanner ,regex))
                            ,target-string ,@rest))
        (t form)))

(defmacro register-groups-bind (var-list (regex target-string
                                                &key start end sharedp)
                                &body body)
  "Executes BODY with the variables in VAR-LIST bound to the
corresponding register groups after TARGET-STRING has been matched
against REGEX, i.e. each variable is either bound to a string or to
NIL. If there is no match, BODY is _not_ executed. For each element of
VAR-LIST which is NIL there's no binding to the corresponding register
group. The number of variables in VAR-LIST must not be greater than
the number of register groups. If SHAREDP is true, the substrings may
share structure with TARGET-STRING."
  (with-rebinding (target-string)
    (with-unique-names (match-start match-end reg-starts reg-ends
                                    start-index substr-fn)
      `(multiple-value-bind (,match-start ,match-end ,reg-starts ,reg-ends)
            (scan ,regex ,target-string :start (or ,start 0)
                                        :end (or ,end (length ,target-string)))
          (declare (ignore ,match-end))
          (when ,match-start            
            (let* ,(cons
                    `(,substr-fn (if ,sharedp
                                   #'nsubseq
                                   #'subseq))
                    (loop for (function var) in (normalize-var-list var-list)
                          for counter from 0
                          when var
                            collect `(,var (let ((,start-index
                                                   (aref ,reg-starts ,counter)))
                                             (if ,start-index
                                               (funcall ,function
                                                        (funcall ,substr-fn
                                                                 ,target-string
                                                                 ,start-index
                                                                 (aref ,reg-ends ,counter)))
                                               nil)))))
              ,@body))))))

(defmacro do-scans ((match-start match-end reg-starts reg-ends regex
                                 target-string
                                 &optional result-form
                                 &key start end)
                    &body body
                    &environment env)
  "Iterates over TARGET-STRING and tries to match REGEX as often as
possible evaluating BODY with MATCH-START, MATCH-END, REG-STARTS, and
REG-ENDS bound to the four return values of each match in turn. After
the last match, returns RESULT-FORM if provided or NIL otherwise. An
implicit block named NIL surrounds DO-SCANS; RETURN may be used to
terminate the loop immediately. If REGEX matches an empty string the
scan is continued one position behind this match. BODY may start with
declarations."
  (with-rebinding (target-string)
    (with-unique-names (%start %end %regex scanner loop-tag block-name)
      (declare (ignorable %regex scanner))
      ;; the NIL BLOCK to enable exits via (RETURN ...)
      `(block nil
        (let* ((,%start (or ,start 0))
               (,%end (or ,end (length ,target-string)))
               ,@(unless (constantp regex env)
                   ;; leave constant regular expressions as they are -
                   ;; SCAN's compiler macro will take care of them;
                   ;; otherwise create a scanner unless the regex is
                   ;; already a function (otherwise SCAN will do this
                   ;; on each iteration)
                   `((,%regex ,regex)
                     (,scanner (typecase ,%regex
                                 (function ,%regex)
                                 (t (create-scanner ,%regex)))))))
          ;; coerce TARGET-STRING to a simple string unless it is one
          ;; already (otherwise SCAN will do this on each iteration)
          (setq ,target-string
                  (maybe-coerce-to-simple-string ,target-string))
          ;; a named BLOCK so we can exit the TAGBODY
          (block ,block-name
            (tagbody
              ,loop-tag
              ;; invoke SCAN and bind the returned values to the
              ;; provided variables
              (multiple-value-bind
                    (,match-start ,match-end ,reg-starts ,reg-ends)
                  (scan ,(cond ((constantp regex env) regex)
                               (t scanner))
                        ,target-string :start ,%start :end ,%end
                                       :real-start-pos (or ,start 0))
                ;; declare the variables to be IGNORABLE to prevent the
                ;; compiler from issuing warnings
                (declare
                  (ignorable ,match-start ,match-end ,reg-starts ,reg-ends))
                (unless ,match-start
                  ;; stop iteration on first failure
                  (return-from ,block-name ,result-form))
                ;; execute BODY (wrapped in LOCALLY so it can start with
                ;; declarations)
                (locally
                  ,@body)
                ;; advance by one position if we had a zero-length match
                (setq ,%start (if (= ,match-start ,match-end)
                                (1+ ,match-end)
                                ,match-end)))
              (go ,loop-tag))))))))

(defmacro do-matches ((match-start match-end regex
                                   target-string
                                   &optional result-form
                                   &key start end)
                      &body body)
  "Iterates over TARGET-STRING and tries to match REGEX as often as
possible evaluating BODY with MATCH-START and MATCH-END bound to the
start/end positions of each match in turn. After the last match,
returns RESULT-FORM if provided or NIL otherwise. An implicit block
named NIL surrounds DO-MATCHES; RETURN may be used to terminate the
loop immediately. If REGEX matches an empty string the scan is
continued one position behind this match. BODY may start with
declarations."
  ;; this is a simplified form of DO-SCANS - we just provide two dummy
  ;; vars and ignore them
  (with-unique-names (reg-starts reg-ends)
    `(do-scans (,match-start ,match-end
                ,reg-starts ,reg-ends
                ,regex ,target-string
                ,result-form
                :start ,start :end ,end)
      ,@body)))

(defmacro do-matches-as-strings ((match-var regex
                                            target-string
                                            &optional result-form
                                            &key start end sharedp)
                                 &body body)
  "Iterates over TARGET-STRING and tries to match REGEX as often as
possible evaluating BODY with MATCH-VAR bound to the substring of
TARGET-STRING corresponding to each match in turn. After the last
match, returns RESULT-FORM if provided or NIL otherwise. An implicit
block named NIL surrounds DO-MATCHES-AS-STRINGS; RETURN may be used to
terminate the loop immediately. If REGEX matches an empty string the
scan is continued one position behind this match. If SHAREDP is true,
the substrings may share structure with TARGET-STRING. BODY may start
with declarations."
  (with-rebinding (target-string)
    (with-unique-names (match-start match-end substr-fn)
      `(let ((,substr-fn (if ,sharedp #'nsubseq #'subseq)))
        ;; simple use DO-MATCHES to extract the substrings
        (do-matches (,match-start ,match-end ,regex ,target-string
                     ,result-form :start ,start :end ,end)
          (let ((,match-var
                  (funcall ,substr-fn
                           ,target-string ,match-start ,match-end)))
            ,@body))))))

(defmacro do-register-groups (var-list (regex target-string
                                              &optional result-form
                                              &key start end sharedp)
                                       &body body)
  "Iterates over TARGET-STRING and tries to match REGEX as often as
possible evaluating BODY with the variables in VAR-LIST bound to the
corresponding register groups for each match in turn, i.e. each
variable is either bound to a string or to NIL. For each element of
VAR-LIST which is NIL there's no binding to the corresponding register
group. The number of variables in VAR-LIST must not be greater than
the number of register groups. After the last match, returns
RESULT-FORM if provided or NIL otherwise. An implicit block named NIL
surrounds DO-REGISTER-GROUPS; RETURN may be used to terminate the loop
immediately. If REGEX matches an empty string the scan is continued
one position behind this match. If SHAREDP is true, the substrings may
share structure with TARGET-STRING. BODY may start with declarations."
  (with-rebinding (target-string)
    (with-unique-names (substr-fn match-start match-end
                                  reg-starts reg-ends start-index)
      `(let ((,substr-fn (if ,sharedp
                          #'nsubseq
                          #'subseq)))
        (do-scans (,match-start ,match-end ,reg-starts ,reg-ends
                                ,regex ,target-string
                                ,result-form :start ,start :end ,end)
          (let ,(loop for (function var) in (normalize-var-list var-list)
                      for counter from 0
                      when var
                        collect `(,var (let ((,start-index
                                               (aref ,reg-starts ,counter)))
                                         (if ,start-index
                                           (funcall ,function
                                                    (funcall ,substr-fn
                                                             ,target-string
                                                             ,start-index
                                                             (aref ,reg-ends ,counter)))
                                           nil))))
            ,@body))))))

(defun all-matches (regex target-string
                          &key (start 0)
                               (end (length target-string)))
  (declare #.*standard-optimize-settings*)
  "Returns a list containing the start and end positions of all
matches of REGEX against TARGET-STRING, i.e. if there are N matches
the list contains (* 2 N) elements. If REGEX matches an empty string
the scan is continued one position behind this match."
  (let (result-list)
    (do-matches (match-start match-end
                 regex target-string
                 (nreverse result-list)
                 :start start :end end)
      (push match-start result-list)
      (push match-end result-list))))

#-:cormanlisp
(define-compiler-macro all-matches (&whole form &environment env regex &rest rest)
   "Make sure that constant forms are compiled into scanners at
compile time."
   (cond ((constantp regex env)
           `(all-matches (load-time-value (create-scanner ,regex))
                         ,@rest))
         (t form)))

(defun all-matches-as-strings (regex target-string
                                     &key (start 0)
                                          (end (length target-string))
                                          sharedp)
  (declare #.*standard-optimize-settings*)
  "Returns a list containing all substrings of TARGET-STRING which
match REGEX. If REGEX matches an empty string the scan is continued
one position behind this match. If SHAREDP is true, the substrings may
share structure with TARGET-STRING."
  (let (result-list)
    (do-matches-as-strings (match regex target-string (nreverse result-list)
                                  :start start :end end :sharedp sharedp)
      (push match result-list))))

#-:cormanlisp
(define-compiler-macro all-matches-as-strings (&whole form &environment env regex &rest rest)
   "Make sure that constant forms are compiled into scanners at
compile time."
   (cond ((constantp regex env)
           `(all-matches-as-strings
             (load-time-value (create-scanner ,regex))
             ,@rest))
         (t form)))

(defun split (regex target-string
                    &key (start 0)
                         (end (length target-string))
                         limit
                         with-registers-p
                         omit-unmatched-p
                         sharedp)
  (declare #.*standard-optimize-settings*)
  "Matches REGEX against TARGET-STRING as often as possible and
returns a list of the substrings between the matches. If
WITH-REGISTERS-P is true, substrings corresponding to matched
registers are inserted into the list as well. If OMIT-UNMATCHED-P is
true, unmatched registers will simply be left out, otherwise they will<