Extract Semgrep regex support helpers
ober
0424b3a31d2b234a9e2734ed7a87248e088fc4b4
--- a/SEMGREP_JERBOA_IMPLEMENTATION.md +++ b/SEMGREP_JERBOA_IMPLEMENTATION.md @@ -459,6 +459,8 @@ Completed in the repo: `src/semgrep/source/offsets.ss` - extracted finding/suppression/binding utility helpers into `src/semgrep/result/findings.ss` + - extracted regex pattern rewriting and regex capture binding helpers into + `src/semgrep/engine/regex-support.ss` Validation at this checkpoint: new file mode 100644 --- /dev/null +++ b/lib/semgrep/engine/regex-support.sls @@ -0,0 +1,246 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/semgrep/engine/regex-support.ss + +(library (semgrep engine regex-support) + (export substring-at? string-find-substring-from + regex-pattern-for-engine make-regex-capture-binding + regex-capture-bindings-at regex-capture-bindings) + (import + (except (chezscheme) make-hash-table hash-table? sort sort! + printf fprintf format path-extension path-absolute? + with-input-from-string with-output-to-string iota \x31;+ + \x31;- partition make-date make-time meta atom?) + (except (jerboa prelude) meta atom?) + (semgrep source offsets) + (semgrep match structural)) + (def (regex-capture-name-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (char=? ch #\_))) + (def (regex-skip-char-class pattern start) + (let ([len (string-length pattern)]) + (let loop ([i (+ start 1)]) + (cond + [(>= i len) len] + [(char=? (string-ref pattern i) #\\) + (loop (min len (+ i 2)))] + [(char=? (string-ref pattern i) #\]) (+ i 1)] + [else (loop (+ i 1))])))) + (def (regex-capture-specs pattern) + (let ([len (string-length pattern)]) + (let loop ([i 0] [acc '()]) + (cond + [(>= i len) (reverse acc)] + [(char=? (string-ref pattern i) #\\) + (loop (min len (+ i 2)) acc)] + [(char=? (string-ref pattern i) #\[) + (loop (regex-skip-char-class pattern i) acc)] + [(and (< (+ i 4) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?) + (char=? (string-ref pattern (+ i 2)) #\P) + (char=? (string-ref pattern (+ i 3)) #\<)) + (let name-loop ([j (+ i 4)]) + (if (and (< j len) + (regex-capture-name-char? (string-ref pattern j))) + (name-loop (+ j 1)) + (if (and (< j len) + (> j (+ i 4)) + (char=? (string-ref pattern j) #\>)) + (loop + (+ j 1) + (cons (substring pattern (+ i 4) j) acc)) + (loop (+ i 1) acc))))] + [(and (< (+ i 3) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?) + (char=? (string-ref pattern (+ i 2)) #\<) + (not (char=? (string-ref pattern (+ i 3)) #\=)) + (not (char=? (string-ref pattern (+ i 3)) #\!))) + (let name-loop ([j (+ i 3)]) + (if (and (< j len) + (regex-capture-name-char? (string-ref pattern j))) + (name-loop (+ j 1)) + (if (and (< j len) + (> j (+ i 3)) + (char=? (string-ref pattern j) #\>)) + (loop + (+ j 1) + (cons (substring pattern (+ i 3) j) acc)) + (loop (+ i 1) acc))))] + [(and (< (+ i 1) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?)) + (loop (+ i 2) acc)] + [(char=? (string-ref pattern i) #\() + (loop (+ i 1) (cons #f acc))] + [else (loop (+ i 1) acc)])))) + (def (regex-leading-case-insensitive? pattern) + (and (<= 4 (string-length pattern)) + (string=? (substring pattern 0 4) "(?i)"))) + (def (regex-case-letter-class ch) + (let ([lower (char-downcase ch)] [upper (char-upcase ch)]) + (if (char=? lower upper) + (string ch) + (string-append "[" (string lower) (string upper) "]")))) + (def (regex-expand-case-insensitive pattern) + (let ([len (string-length pattern)]) + (let loop ([i 0] [in-class? #f] [acc '()]) + (cond + [(>= i len) (list->string (reverse acc))] + [(char=? (string-ref pattern i) #\\) + (if (< (+ i 1) len) + (loop + (+ i 2) + in-class? + (cons + (string-ref pattern (+ i 1)) + (cons (string-ref pattern i) acc))) + (loop + (+ i 1) + in-class? + (cons (string-ref pattern i) acc)))] + [(and (not in-class?) (char=? (string-ref pattern i) #\[)) + (loop (+ i 1) #t (cons (string-ref pattern i) acc))] + [(and in-class? (char=? (string-ref pattern i) #\])) + (loop (+ i 1) #f (cons (string-ref pattern i) acc))] + [(and (not in-class?) + (char-alphabetic? (string-ref pattern i))) + (let ([expanded (regex-case-letter-class + (string-ref pattern i))]) + (let chars ([j 0] [next acc]) + (if (= j (string-length expanded)) + (loop (+ i 1) in-class? next) + (chars + (+ j 1) + (cons (string-ref expanded j) next)))))] + [else + (loop + (+ i 1) + in-class? + (cons (string-ref pattern i) acc))])))) + (def (regex-add-string-reversed text acc) + (let ([len (string-length text)]) + (let loop ([i 0] [current acc]) + (if (= i len) + current + (loop (+ i 1) (cons (string-ref text i) current)))))) + (def (regex-pattern-for-engine-raw pattern) + (let ([len (string-length pattern)]) + (let loop ([i 0] [acc '()]) + (cond + [(>= i len) (list->string (reverse acc))] + [(and (< (+ i 5) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\.) + (char=? (string-ref pattern (+ i 2)) #\+) + (char=? (string-ref pattern (+ i 3)) #\)) + (char=? (string-ref pattern (+ i 4)) #\?) + (char=? (string-ref pattern (+ i 5)) #\")) + (loop (+ i 5) (regex-add-string-reversed "([^\"]+)?" acc))] + [(and (< (+ i 4) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?) + (char=? (string-ref pattern (+ i 2)) #\P) + (char=? (string-ref pattern (+ i 3)) #\<)) + (let name-loop ([j (+ i 4)]) + (if (and (< j len) + (not (char=? (string-ref pattern j) #\>))) + (name-loop (+ j 1)) + (loop (+ j 1) (cons #\( acc))))] + [(and (< (+ i 3) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?) + (char=? (string-ref pattern (+ i 2)) #\<) + (not (char=? (string-ref pattern (+ i 3)) #\=)) + (not (char=? (string-ref pattern (+ i 3)) #\!))) + (let name-loop ([j (+ i 3)]) + (if (and (< j len) + (not (char=? (string-ref pattern j) #\>))) + (name-loop (+ j 1)) + (loop (+ j 1) (cons #\( acc))))] + [else (loop (+ i 1) (cons (string-ref pattern i) acc))])))) + (def (regex-pattern-for-engine pattern) + (cond + [(regex-leading-case-insensitive? pattern) + (regex-pattern-for-engine-raw + (regex-expand-case-insensitive + (substring pattern 4 (string-length pattern))))] + [(string-find-substring-from pattern "(?i)" 0) => + (lambda (index) + (string-append + (regex-pattern-for-engine-raw (substring pattern 0 index)) + (regex-pattern-for-engine-raw + (regex-expand-case-insensitive + (substring + pattern + (+ index 4) + (string-length pattern))))))] + [else (regex-pattern-for-engine-raw pattern)])) + (def (substring-at? s needle i) + (let ([needle-len (string-length needle)]) + (and (<= (+ i needle-len) (string-length s)) + (string=? (substring s i (+ i needle-len)) needle)))) + (def (string-find-substring-from s needle start) + (let ([len (string-length s)]) + (let loop ([i start]) + (cond + [(> i len) #f] + [(substring-at? s needle i) i] + [else (loop (+ i 1))])))) + (def (make-regex-capture-binding name text source start end) + (let-values ([(start-line start-col) + (offset->line-col source start)] + [(end-line end-col) (offset->line-col source end)]) + (make-metavariable-binding name text start end start-line + start-col end-line end-col))) + (def (regex-capture-bindings-at + pattern + source + match + input-start) + (let* ([specs (regex-capture-specs pattern)] + [match-start (+ input-start (re-match-start match))] + [full (re-match-full match)]) + (let loop ([remaining specs] + [index 1] + [search-start 0] + [acc '()]) + (cond + [(null? remaining) (reverse acc)] + [else + (let ([text (re-match-group match index)]) + (if (not text) + (loop (cdr remaining) (+ index 1) search-start acc) + (let* ([relative (or (string-find-substring-from + full + text + search-start) + 0)] + [start (+ match-start relative)] + [end (+ start (string-length text))] + [numeric-name (number->string index)] + [numeric-binding (make-regex-capture-binding numeric-name text source + start end)] + [named-name (car remaining)] + [with-numeric (cons + (cons + numeric-name + numeric-binding) + acc)] + [next-acc (if named-name + (cons + (cons + named-name + (make-regex-capture-binding named-name text source start + end)) + with-numeric) + with-numeric)]) + (loop + (cdr remaining) + (+ index 1) + (+ relative (string-length text)) + next-acc))))])))) + (def (regex-capture-bindings pattern source match) + (regex-capture-bindings-at pattern source match 0))) --- a/lib/semgrep/scan.sls +++ b/lib/semgrep/scan.sls @@ -16,9 +16,10 @@ (except (jerboa prelude) meta atom?) (std regex) (tree-sitter tree-sitter) (semgrep lang) (semgrep rule) (semgrep result) (semgrep result findings) - (semgrep engine rule-plan) (semgrep rule parse-rule) - (semgrep parse parse-target) (semgrep source offsets) - (semgrep targeting path-filter) (semgrep match structural)) + (semgrep engine rule-plan) (semgrep engine regex-support) + (semgrep rule parse-rule) (semgrep parse parse-target) + (semgrep source offsets) (semgrep targeting path-filter) + (semgrep match structural)) (def (alist-ref/default xs key default) (let ([found (assoc key xs)]) (if found (cdr found) default))) @@ -45,236 +46,6 @@ [(null? xs) '()] [(eq? target (car xs)) (cdr xs)] [else (cons (car xs) (remove-first-eq target (cdr xs)))])) - (def (regex-capture-name-char? ch) - (or (char-alphabetic? ch) - (char-numeric? ch) - (char=? ch #\_))) - (def (regex-skip-char-class pattern start) - (let ([len (string-length pattern)]) - (let loop ([i (+ start 1)]) - (cond - [(>= i len) len] - [(char=? (string-ref pattern i) #\\) - (loop (min len (+ i 2)))] - [(char=? (string-ref pattern i) #\]) (+ i 1)] - [else (loop (+ i 1))])))) - (def (regex-capture-specs pattern) - (let ([len (string-length pattern)]) - (let loop ([i 0] [acc '()]) - (cond - [(>= i len) (reverse acc)] - [(char=? (string-ref pattern i) #\\) - (loop (min len (+ i 2)) acc)] - [(char=? (string-ref pattern i) #\[) - (loop (regex-skip-char-class pattern i) acc)] - [(and (< (+ i 4) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?) - (char=? (string-ref pattern (+ i 2)) #\P) - (char=? (string-ref pattern (+ i 3)) #\<)) - (let name-loop ([j (+ i 4)]) - (if (and (< j len) - (regex-capture-name-char? (string-ref pattern j))) - (name-loop (+ j 1)) - (if (and (< j len) - (> j (+ i 4)) - (char=? (string-ref pattern j) #\>)) - (loop - (+ j 1) - (cons (substring pattern (+ i 4) j) acc)) - (loop (+ i 1) acc))))] - [(and (< (+ i 3) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?) - (char=? (string-ref pattern (+ i 2)) #\<) - (not (char=? (string-ref pattern (+ i 3)) #\=)) - (not (char=? (string-ref pattern (+ i 3)) #\!))) - (let name-loop ([j (+ i 3)]) - (if (and (< j len) - (regex-capture-name-char? (string-ref pattern j))) - (name-loop (+ j 1)) - (if (and (< j len) - (> j (+ i 3)) - (char=? (string-ref pattern j) #\>)) - (loop - (+ j 1) - (cons (substring pattern (+ i 3) j) acc)) - (loop (+ i 1) acc))))] - [(and (< (+ i 1) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?)) - (loop (+ i 2) acc)] - [(char=? (string-ref pattern i) #\() - (loop (+ i 1) (cons #f acc))] - [else (loop (+ i 1) acc)])))) - (def (regex-leading-case-insensitive? pattern) - (and (<= 4 (string-length pattern)) - (string=? (substring pattern 0 4) "(?i)"))) - (def (regex-case-letter-class ch) - (let ([lower (char-downcase ch)] [upper (char-upcase ch)]) - (if (char=? lower upper) - (string ch) - (string-append "[" (string lower) (string upper) "]")))) - (def (regex-expand-case-insensitive pattern) - (let ([len (string-length pattern)]) - (let loop ([i 0] [in-class? #f] [acc '()]) - (cond - [(>= i len) (list->string (reverse acc))] - [(char=? (string-ref pattern i) #\\) - (if (< (+ i 1) len) - (loop - (+ i 2) - in-class? - (cons - (string-ref pattern (+ i 1)) - (cons (string-ref pattern i) acc))) - (loop - (+ i 1) - in-class? - (cons (string-ref pattern i) acc)))] - [(and (not in-class?) (char=? (string-ref pattern i) #\[)) - (loop (+ i 1) #t (cons (string-ref pattern i) acc))] - [(and in-class? (char=? (string-ref pattern i) #\])) - (loop (+ i 1) #f (cons (string-ref pattern i) acc))] - [(and (not in-class?) - (char-alphabetic? (string-ref pattern i))) - (let ([expanded (regex-case-letter-class - (string-ref pattern i))]) - (let chars ([j 0] [next acc]) - (if (= j (string-length expanded)) - (loop (+ i 1) in-class? next) - (chars - (+ j 1) - (cons (string-ref expanded j) next)))))] - [else - (loop - (+ i 1) - in-class? - (cons (string-ref pattern i) acc))])))) - (def (regex-add-string-reversed text acc) - (let ([len (string-length text)]) - (let loop ([i 0] [current acc]) - (if (= i len) - current - (loop (+ i 1) (cons (string-ref text i) current)))))) - (def (regex-pattern-for-engine-raw pattern) - (let ([len (string-length pattern)]) - (let loop ([i 0] [acc '()]) - (cond - [(>= i len) (list->string (reverse acc))] - [(and (< (+ i 5) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\.) - (char=? (string-ref pattern (+ i 2)) #\+) - (char=? (string-ref pattern (+ i 3)) #\)) - (char=? (string-ref pattern (+ i 4)) #\?) - (char=? (string-ref pattern (+ i 5)) #\")) - (loop (+ i 5) (regex-add-string-reversed "([^\"]+)?" acc))] - [(and (< (+ i 4) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?) - (char=? (string-ref pattern (+ i 2)) #\P) - (char=? (string-ref pattern (+ i 3)) #\<)) - (let name-loop ([j (+ i 4)]) - (if (and (< j len) - (not (char=? (string-ref pattern j) #\>))) - (name-loop (+ j 1)) - (loop (+ j 1) (cons #\( acc))))] - [(and (< (+ i 3) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?) - (char=? (string-ref pattern (+ i 2)) #\<) - (not (char=? (string-ref pattern (+ i 3)) #\=)) - (not (char=? (string-ref pattern (+ i 3)) #\!))) - (let name-loop ([j (+ i 3)]) - (if (and (< j len) - (not (char=? (string-ref pattern j) #\>))) - (name-loop (+ j 1)) - (loop (+ j 1) (cons #\( acc))))] - [else (loop (+ i 1) (cons (string-ref pattern i) acc))])))) - (def (regex-pattern-for-engine pattern) - (cond - [(regex-leading-case-insensitive? pattern) - (regex-pattern-for-engine-raw - (regex-expand-case-insensitive - (substring pattern 4 (string-length pattern))))] - [(string-find-substring pattern "(?i)") => - (lambda (index) - (string-append - (regex-pattern-for-engine-raw (substring pattern 0 index)) - (regex-pattern-for-engine-raw - (regex-expand-case-insensitive - (substring - pattern - (+ index 4) - (string-length pattern))))))] - [else (regex-pattern-for-engine-raw pattern)])) - (def (substring-at? s needle i) - (let ([needle-len (string-length needle)]) - (and (<= (+ i needle-len) (string-length s)) - (string=? (substring s i (+ i needle-len)) needle)))) - (def (string-find-substring-from s needle start) - (let ([len (string-length s)]) - (let loop ([i start]) - (cond - [(> i len) #f] - [(substring-at? s needle i) i] - [else (loop (+ i 1))])))) - (def (make-regex-capture-binding name text source start end) - (let-values ([(start-line start-col) - (offset->line-col source start)] - [(end-line end-col) (offset->line-col source end)]) - (make-metavariable-binding name text start end start-line - start-col end-line end-col))) - (def (regex-capture-bindings-at - pattern - source - match - input-start) - (let* ([specs (regex-capture-specs pattern)] - [match-start (+ input-start (re-match-start match))] - [full (re-match-full match)]) - (let loop ([remaining specs] - [index 1] - [search-start 0] - [acc '()]) - (cond - [(null? remaining) (reverse acc)] - [else - (let ([text (re-match-group match index)]) - (if (not text) - (loop (cdr remaining) (+ index 1) search-start acc) - (let* ([relative (or (string-find-substring-from - full - text - search-start) - 0)] - [start (+ match-start relative)] - [end (+ start (string-length text))] - [numeric-name (number->string index)] - [numeric-binding (make-regex-capture-binding numeric-name text source - start end)] - [named-name (car remaining)] - [with-numeric (cons - (cons - numeric-name - numeric-binding) - acc)] - [next-acc (if named-name - (cons - (cons - named-name - (make-regex-capture-binding named-name text source start - end)) - with-numeric) - with-numeric)]) - (loop - (cdr remaining) - (+ index 1) - (+ relative (string-length text)) - next-acc))))])))) - (def (regex-capture-bindings pattern source match) - (regex-capture-bindings-at pattern source match 0)) (def (finding-from-match rule path source match) (let ([start (re-match-start match)] [end (re-match-end match)]) --- a/src/.jerbuild-hashes +++ b/src/.jerbuild-hashes @@ -8,10 +8,11 @@ ("src/semgrep/output/json.ss" . "293881CFA2ADB7BC") ("src/semgrep/lang.ss" . "6982E07679D20836") ("src/semgrep/parse/parse-target.ss" . "97AA8FFEB12736DA") - ("src/semgrep/scan.ss" . "5C81EB3CE9F8F328") + ("src/semgrep/scan.ss" . "54C4A1386DE353B4") ("src/semgrep/rule.ss" . "E12C108153C181FA") ("src/semgrep/schema/lang.ss" . "CAE2CA859C9A9FD0") ("src/semgrep/output/text.ss" . "BE476CB84B807FBA") ("src/semgrep/source/offsets.ss" . "834EFDB706823794") + ("src/semgrep/engine/regex-support.ss" . "9FCF118903259C97") ("src/semgrep/main.ss" . "A4EC9E7F2A09D25E") ("src/semgrep/cli.ss" . "EBDC4B1DAD3F13CC")) new file mode 100644 --- /dev/null +++ b/src/semgrep/engine/regex-support.ss @@ -0,0 +1,255 @@ +(export + substring-at? + string-find-substring-from + regex-pattern-for-engine + make-regex-capture-binding + regex-capture-bindings-at + regex-capture-bindings) + +(import (except (jerboa prelude) meta atom?) + (semgrep source offsets) + (semgrep match structural)) + +(def (regex-capture-name-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (char=? ch #\_))) + +(def (regex-skip-char-class pattern start) + (let ([len (string-length pattern)]) + (let loop ([i (+ start 1)]) + (cond + [(>= i len) len] + [(char=? (string-ref pattern i) #\\) + (loop (min len (+ i 2)))] + [(char=? (string-ref pattern i) #\]) + (+ i 1)] + [else (loop (+ i 1))])))) + +(def (regex-capture-specs pattern) + (let ([len (string-length pattern)]) + (let loop ([i 0] [acc '()]) + (cond + [(>= i len) (reverse acc)] + [(char=? (string-ref pattern i) #\\) + (loop (min len (+ i 2)) acc)] + [(char=? (string-ref pattern i) #\[) + (loop (regex-skip-char-class pattern i) acc)] + [(and (< (+ i 4) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?) + (char=? (string-ref pattern (+ i 2)) #\P) + (char=? (string-ref pattern (+ i 3)) #\<)) + (let name-loop ([j (+ i 4)]) + (if (and (< j len) + (regex-capture-name-char? (string-ref pattern j))) + (name-loop (+ j 1)) + (if (and (< j len) + (> j (+ i 4)) + (char=? (string-ref pattern j) #\>)) + (loop (+ j 1) + (cons (substring pattern (+ i 4) j) acc)) + (loop (+ i 1) acc))))] + [(and (< (+ i 3) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?) + (char=? (string-ref pattern (+ i 2)) #\<) + (not (char=? (string-ref pattern (+ i 3)) #\=)) + (not (char=? (string-ref pattern (+ i 3)) #\!))) + (let name-loop ([j (+ i 3)]) + (if (and (< j len) + (regex-capture-name-char? (string-ref pattern j))) + (name-loop (+ j 1)) + (if (and (< j len) + (> j (+ i 3)) + (char=? (string-ref pattern j) #\>)) + (loop (+ j 1) + (cons (substring pattern (+ i 3) j) acc)) + (loop (+ i 1) acc))))] + [(and (< (+ i 1) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?)) + (loop (+ i 2) acc)] + [(char=? (string-ref pattern i) #\() + (loop (+ i 1) (cons #f acc))] + [else (loop (+ i 1) acc)])))) + +(def (regex-leading-case-insensitive? pattern) + (and (<= 4 (string-length pattern)) + (string=? (substring pattern 0 4) "(?i)"))) + +(def (regex-case-letter-class ch) + (let ([lower (char-downcase ch)] + [upper (char-upcase ch)]) + (if (char=? lower upper) + (string ch) + (string-append "[" + (string lower) + (string upper) + "]")))) + +(def (regex-expand-case-insensitive pattern) + (let ([len (string-length pattern)]) + (let loop ([i 0] [in-class? #f] [acc '()]) + (cond + [(>= i len) (list->string (reverse acc))] + [(char=? (string-ref pattern i) #\\) + (if (< (+ i 1) len) + (loop (+ i 2) + in-class? + (cons (string-ref pattern (+ i 1)) + (cons (string-ref pattern i) acc))) + (loop (+ i 1) in-class? (cons (string-ref pattern i) acc)))] + [(and (not in-class?) (char=? (string-ref pattern i) #\[)) + (loop (+ i 1) #t (cons (string-ref pattern i) acc))] + [(and in-class? (char=? (string-ref pattern i) #\])) + (loop (+ i 1) #f (cons (string-ref pattern i) acc))] + [(and (not in-class?) (char-alphabetic? (string-ref pattern i))) + (let ([expanded (regex-case-letter-class (string-ref pattern i))]) + (let chars ([j 0] [next acc]) + (if (= j (string-length expanded)) + (loop (+ i 1) in-class? next) + (chars (+ j 1) (cons (string-ref expanded j) next)))))] + [else + (loop (+ i 1) in-class? (cons (string-ref pattern i) acc))])))) + +(def (regex-add-string-reversed text acc) + (let ([len (string-length text)]) + (let loop ([i 0] [current acc]) + (if (= i len) + current + (loop (+ i 1) (cons (string-ref text i) current)))))) + +(def (regex-pattern-for-engine-raw pattern) + (let ([len (string-length pattern)]) + (let loop ([i 0] [acc '()]) + (cond + [(>= i len) (list->string (reverse acc))] + [(and (< (+ i 5) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\.) + (char=? (string-ref pattern (+ i 2)) #\+) + (char=? (string-ref pattern (+ i 3)) #\)) + (char=? (string-ref pattern (+ i 4)) #\?) + (char=? (string-ref pattern (+ i 5)) #\")) + (loop (+ i 5) + (regex-add-string-reversed "([^\"]+)?" + acc))] + [(and (< (+ i 4) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?) + (char=? (string-ref pattern (+ i 2)) #\P) + (char=? (string-ref pattern (+ i 3)) #\<)) + (let name-loop ([j (+ i 4)]) + (if (and (< j len) + (not (char=? (string-ref pattern j) #\>))) + (name-loop (+ j 1)) + (loop (+ j 1) (cons #\( acc))))] + [(and (< (+ i 3) len) + (char=? (string-ref pattern i) #\() + (char=? (string-ref pattern (+ i 1)) #\?) + (char=? (string-ref pattern (+ i 2)) #\<) + (not (char=? (string-ref pattern (+ i 3)) #\=)) + (not (char=? (string-ref pattern (+ i 3)) #\!))) + (let name-loop ([j (+ i 3)]) + (if (and (< j len) + (not (char=? (string-ref pattern j) #\>))) + (name-loop (+ j 1)) + (loop (+ j 1) (cons #\( acc))))] + [else (loop (+ i 1) (cons (string-ref pattern i) acc))])))) + +(def (regex-pattern-for-engine pattern) + (cond + [(regex-leading-case-insensitive? pattern) + (regex-pattern-for-engine-raw + (regex-expand-case-insensitive + (substring pattern 4 (string-length pattern))))] + [(string-find-substring-from pattern "(?i)" 0) + => (lambda (index) + (string-append + (regex-pattern-for-engine-raw + (substring pattern 0 index)) + (regex-pattern-for-engine-raw + (regex-expand-case-insensitive + (substring pattern + (+ index 4) + (string-length pattern))))))] + [else (regex-pattern-for-engine-raw pattern)])) + +(def (substring-at? s needle i) + (let ([needle-len (string-length needle)]) + (and (<= (+ i needle-len) (string-length s)) + (string=? (substring s i (+ i needle-len)) needle)))) + +(def (string-find-substring-from s needle start) + (let ([len (string-length s)]) + (let loop ([i start]) + (cond + [(> i len) #f] + [(substring-at? s needle i) i] + [else (loop (+ i 1))])))) + +(def (make-regex-capture-binding name text source start end) + (let-values ([(start-line start-col) + (offset->line-col source start)] + [(end-line end-col) + (offset->line-col source end)]) + (make-metavariable-binding + name + text + start + end + start-line + start-col + end-line + end-col))) + +(def (regex-capture-bindings-at pattern source match input-start) + (let* ([specs (regex-capture-specs pattern)] + [match-start (+ input-start (re-match-start match))] + [full (re-match-full match)]) + (let loop ([remaining specs] [index 1] [search-start 0] [acc '()]) + (cond + [(null? remaining) (reverse acc)] + [else + (let ([text (re-match-group match index)]) + (if (not text) + (loop (cdr remaining) (+ index 1) search-start acc) + (let* ([relative (or (string-find-substring-from + full + text + search-start) + 0)] + [start (+ match-start relative)] + [end (+ start (string-length text))] + [numeric-name (number->string index)] + [numeric-binding + (make-regex-capture-binding + numeric-name + text + source + start + end)] + [named-name (car remaining)] + [with-numeric + (cons (cons numeric-name numeric-binding) acc)] + [next-acc + (if named-name + (cons + (cons named-name + (make-regex-capture-binding + named-name + text + source + start + end)) + with-numeric) + with-numeric)]) + (loop + (cdr remaining) + (+ index 1) + (+ relative (string-length text)) + next-acc))))])))) + +(def (regex-capture-bindings pattern source match) + (regex-capture-bindings-at pattern source match 0)) --- a/src/semgrep/scan.ss +++ b/src/semgrep/scan.ss @@ -12,6 +12,7 @@ (semgrep result) (semgrep result findings) (semgrep engine rule-plan) + (semgrep engine regex-support) (semgrep rule parse-rule) (semgrep parse parse-target) (semgrep source offsets) @@ -52,250 +53,6 @@ [(eq? target (car xs)) (cdr xs)] [else (cons (car xs) (remove-first-eq target (cdr xs)))])) -(def (regex-capture-name-char? ch) - (or (char-alphabetic? ch) - (char-numeric? ch) - (char=? ch #\_))) - -(def (regex-skip-char-class pattern start) - (let ([len (string-length pattern)]) - (let loop ([i (+ start 1)]) - (cond - [(>= i len) len] - [(char=? (string-ref pattern i) #\\) - (loop (min len (+ i 2)))] - [(char=? (string-ref pattern i) #\]) - (+ i 1)] - [else (loop (+ i 1))])))) - -(def (regex-capture-specs pattern) - (let ([len (string-length pattern)]) - (let loop ([i 0] [acc '()]) - (cond - [(>= i len) (reverse acc)] - [(char=? (string-ref pattern i) #\\) - (loop (min len (+ i 2)) acc)] - [(char=? (string-ref pattern i) #\[) - (loop (regex-skip-char-class pattern i) acc)] - [(and (< (+ i 4) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?) - (char=? (string-ref pattern (+ i 2)) #\P) - (char=? (string-ref pattern (+ i 3)) #\<)) - (let name-loop ([j (+ i 4)]) - (if (and (< j len) - (regex-capture-name-char? (string-ref pattern j))) - (name-loop (+ j 1)) - (if (and (< j len) - (> j (+ i 4)) - (char=? (string-ref pattern j) #\>)) - (loop (+ j 1) - (cons (substring pattern (+ i 4) j) acc)) - (loop (+ i 1) acc))))] - [(and (< (+ i 3) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?) - (char=? (string-ref pattern (+ i 2)) #\<) - (not (char=? (string-ref pattern (+ i 3)) #\=)) - (not (char=? (string-ref pattern (+ i 3)) #\!))) - (let name-loop ([j (+ i 3)]) - (if (and (< j len) - (regex-capture-name-char? (string-ref pattern j))) - (name-loop (+ j 1)) - (if (and (< j len) - (> j (+ i 3)) - (char=? (string-ref pattern j) #\>)) - (loop (+ j 1) - (cons (substring pattern (+ i 3) j) acc)) - (loop (+ i 1) acc))))] - [(and (< (+ i 1) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?)) - (loop (+ i 2) acc)] - [(char=? (string-ref pattern i) #\() - (loop (+ i 1) (cons #f acc))] - [else (loop (+ i 1) acc)])))) - -(def (regex-leading-case-insensitive? pattern) - (and (<= 4 (string-length pattern)) - (string=? (substring pattern 0 4) "(?i)"))) - -(def (regex-case-letter-class ch) - (let ([lower (char-downcase ch)] - [upper (char-upcase ch)]) - (if (char=? lower upper) - (string ch) - (string-append "[" - (string lower) - (string upper) - "]")))) - -(def (regex-expand-case-insensitive pattern) - (let ([len (string-length pattern)]) - (let loop ([i 0] [in-class? #f] [acc '()]) - (cond - [(>= i len) (list->string (reverse acc))] - [(char=? (string-ref pattern i) #\\) - (if (< (+ i 1) len) - (loop (+ i 2) - in-class? - (cons (string-ref pattern (+ i 1)) - (cons (string-ref pattern i) acc))) - (loop (+ i 1) in-class? (cons (string-ref pattern i) acc)))] - [(and (not in-class?) (char=? (string-ref pattern i) #\[)) - (loop (+ i 1) #t (cons (string-ref pattern i) acc))] - [(and in-class? (char=? (string-ref pattern i) #\])) - (loop (+ i 1) #f (cons (string-ref pattern i) acc))] - [(and (not in-class?) (char-alphabetic? (string-ref pattern i))) - (let ([expanded (regex-case-letter-class (string-ref pattern i))]) - (let chars ([j 0] [next acc]) - (if (= j (string-length expanded)) - (loop (+ i 1) in-class? next) - (chars (+ j 1) (cons (string-ref expanded j) next)))))] - [else - (loop (+ i 1) in-class? (cons (string-ref pattern i) acc))])))) - -(def (regex-add-string-reversed text acc) - (let ([len (string-length text)]) - (let loop ([i 0] [current acc]) - (if (= i len) - current - (loop (+ i 1) (cons (string-ref text i) current)))))) - -(def (regex-pattern-for-engine-raw pattern) - (let ([len (string-length pattern)]) - (let loop ([i 0] [acc '()]) - (cond - [(>= i len) (list->string (reverse acc))] - [(and (< (+ i 5) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\.) - (char=? (string-ref pattern (+ i 2)) #\+) - (char=? (string-ref pattern (+ i 3)) #\)) - (char=? (string-ref pattern (+ i 4)) #\?) - (char=? (string-ref pattern (+ i 5)) #\")) - (loop (+ i 5) - (regex-add-string-reversed "([^\"]+)?" - acc))] - [(and (< (+ i 4) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?) - (char=? (string-ref pattern (+ i 2)) #\P) - (char=? (string-ref pattern (+ i 3)) #\<)) - (let name-loop ([j (+ i 4)]) - (if (and (< j len) - (not (char=? (string-ref pattern j) #\>))) - (name-loop (+ j 1)) - (loop (+ j 1) (cons #\( acc))))] - [(and (< (+ i 3) len) - (char=? (string-ref pattern i) #\() - (char=? (string-ref pattern (+ i 1)) #\?) - (char=? (string-ref pattern (+ i 2)) #\<) - (not (char=? (string-ref pattern (+ i 3)) #\=)) - (not (char=? (string-ref pattern (+ i 3)) #\!))) - (let name-loop ([j (+ i 3)]) - (if (and (< j len) - (not (char=? (string-ref pattern j) #\>))) - (name-loop (+ j 1)) - (loop (+ j 1) (cons #\( acc))))] - [else (loop (+ i 1) (cons (string-ref pattern i) acc))])))) - -(def (regex-pattern-for-engine pattern) - (cond - [(regex-leading-case-insensitive? pattern) - (regex-pattern-for-engine-raw - (regex-expand-case-insensitive - (substring pattern 4 (string-length pattern))))] - [(string-find-substring pattern "(?i)") - => (lambda (index) - (string-append - (regex-pattern-for-engine-raw - (substring pattern 0 index)) - (regex-pattern-for-engine-raw - (regex-expand-case-insensitive - (substring pattern - (+ index 4) - (string-length pattern))))))] - [else (regex-pattern-for-engine-raw pattern)])) - -(def (substring-at? s needle i) - (let ([needle-len (string-length needle)]) - (and (<= (+ i needle-len) (string-length s)) - (string=? (substring s i (+ i needle-len)) needle)))) - -(def (string-find-substring-from s needle start) - (let ([len (string-length s)]) - (let loop ([i start]) - (cond - [(> i len) #f] - [(substring-at? s needle i) i] - [else (loop (+ i 1))])))) - -(def (make-regex-capture-binding name text source start end) - (let-values ([(start-line start-col) - (offset->line-col source start)] - [(end-line end-col) - (offset->line-col source end)]) - (make-metavariable-binding - name - text - start - end - start-line - start-col - end-line - end-col))) - -(def (regex-capture-bindings-at pattern source match input-start) - (let* ([specs (regex-capture-specs pattern)] - [match-start (+ input-start (re-match-start match))] - [full (re-match-full match)]) - (let loop ([remaining specs] [index 1] [search-start 0] [acc '()]) - (cond - [(null? remaining) (reverse acc)] - [else - (let ([text (re-match-group match index)]) - (if (not text) - (loop (cdr remaining) (+ index 1) search-start acc)