Extract Semgrep regex scanning and literal utilities
ober
c5578108e7ab58fb67fc1b0befe8b1562e900d33
--- a/SEMGREP_JERBOA_IMPLEMENTATION.md +++ b/SEMGREP_JERBOA_IMPLEMENTATION.md @@ -463,6 +463,12 @@ Completed in the repo: `src/semgrep/engine/regex-support.ss` - extracted node/binding finding builders and semicolon range shaping into `src/semgrep/result/builders.ss` + - extracted quoted-string and number-literal parsing helpers into + `src/semgrep/util/literals.ss` + - extracted finding extra assembly, fix rendering, and focus helpers into + `src/semgrep/result/extras.ss` + - extracted regex rule scanning and regex-backed finding builders into + `src/semgrep/engine/regex-scan.ss` Validation at this checkpoint: new file mode 100644 --- /dev/null +++ b/lib/semgrep/engine/regex-scan.sls @@ -0,0 +1,147 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/semgrep/engine/regex-scan.ss + +(library (semgrep engine regex-scan) + (export + finding-from-match + finding-for-whole-text + scan-regex-pattern-with-line-anchors + scan-regex-rule) + (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?) (std regex) + (semgrep rule) (semgrep result) (semgrep result extras) + (semgrep result findings) (semgrep engine regex-support) + (semgrep source offsets)) + (def (finding-from-match rule path source match) + (let ([start (re-match-start match)] + [end (re-match-end match)]) + (let-values ([(start-line start-col) + (offset->line-col source start)] + [(end-line end-col) (offset->line-col source end)]) + (make-finding (rule-id rule) path start-line start-col end-line end-col + start end (rule-message rule) (rule-severity rule) + (finding-extra-for-match + rule + '() + (substring source start end)))))) + (def (finding-from-regex-match-at rule path source pattern + match input-start) + (let* ([start (+ input-start (re-match-start match))] + [end (+ input-start (re-match-end match))] + [bindings (regex-capture-bindings-at + pattern + source + match + input-start)]) + (let-values ([(start-line start-col) + (offset->line-col source start)] + [(end-line end-col) (offset->line-col source end)]) + (make-finding (rule-id rule) path start-line start-col end-line end-col + start end (render-fix-template (rule-message rule) bindings) + (rule-severity rule) + (finding-extra-for-match + rule + bindings + (substring source start end)))))) + (def (finding-from-regex-match rule path source pattern + match) + (finding-from-regex-match-at rule path source pattern match + 0)) + (def (finding-for-whole-text rule path source) + (let ([end (string-length source)]) + (let-values ([(end-line end-col) + (offset->line-col source end)]) + (make-finding (rule-id rule) path 1 1 end-line end-col 0 end + (rule-message rule) (rule-severity rule) + (finding-extra-for-match rule '() source))))) + (def (scan-regex-pattern rule path source pattern) + (let ([rx (re (regex-pattern-for-engine pattern))] + [len (string-length source)]) + (let loop ([start 0] [acc '()]) + (if (> start len) + (reverse acc) + (let ([match (re-search rx source start)]) + (if match + (let* ([finding (finding-from-regex-match rule path + source pattern match)] + [next (max (+ (re-match-start match) 1) + (re-match-end match))]) + (loop + next + (append + (reverse (apply-rule-focus rule finding)) + acc))) + (reverse acc))))))) + (def (regex-uses-line-anchor? pattern) + (let ([len (string-length pattern)]) + (let loop ([i 0] [escaped? #f]) + (cond + [(= i len) #f] + [escaped? (loop (+ i 1) #f)] + [(char=? (string-ref pattern i) #\\) (loop (+ i 1) #t)] + [(or (char=? (string-ref pattern i) #\^) + (char=? (string-ref pattern i) #\$)) + #t] + [else (loop (+ i 1) #f)])))) + (def (scan-regex-pattern-line rule path source pattern line + line-start) + (let ([rx (re (regex-pattern-for-engine pattern))] + [len (string-length line)]) + (let loop ([start 0] [acc '()]) + (if (> start len) + (reverse acc) + (let ([match (re-search rx line start)]) + (if match + (let* ([finding (finding-from-regex-match-at rule path source pattern match + line-start)] + [next (max (+ (re-match-start match) 1) + (re-match-end match))]) + (loop + next + (append + (reverse (apply-rule-focus rule finding)) + acc))) + (reverse acc))))))) + (def (scan-regex-pattern-lines rule path source pattern) + (let ([len (string-length source)]) + (let loop ([i 0] [line-start 0] [acc '()]) + (cond + [(= i len) + (reverse + (append + (reverse + (scan-regex-pattern-line rule path source pattern + (substring source line-start len) line-start)) + acc))] + [(char=? (string-ref source i) #\newline) + (loop + (+ i 1) + (+ i 1) + (append + (reverse + (scan-regex-pattern-line rule path source pattern + (substring source line-start i) line-start)) + acc))] + [else (loop (+ i 1) line-start acc)])))) + (def (scan-regex-pattern-with-line-anchors + rule + path + source + pattern) + (if (regex-uses-line-anchor? pattern) + (dedupe-findings + (append + (scan-regex-pattern rule path source pattern) + (scan-regex-pattern-lines rule path source pattern))) + (scan-regex-pattern rule path source pattern))) + (def (scan-regex-rule rule path source) + (scan-regex-pattern-with-line-anchors + rule + path + source + (rule-pattern rule)))) new file mode 100644 --- /dev/null +++ b/lib/semgrep/result/extras.sls @@ -0,0 +1,181 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/semgrep/result/extras.ss + +(library (semgrep result extras) + (export internal-match-range-name + internal-resolved-decomposition-name render-fix-template + public-bindings finding-extra-for-match + finding-extra-for-bindings focus-binding-from-list + focus-binding apply-rule-focus) + (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?) (std regex) + (semgrep rule) (semgrep result) (semgrep result findings) + (semgrep engine regex-support) (semgrep util literals) + (semgrep match structural)) + (def (alist-ref/default xs key default) + (let ([found (assoc key xs)]) + (if found (cdr found) default))) + (def (base-finding-extra rule) + (if (null? (rule-metadata rule)) + '() + (list (cons 'metadata (rule-metadata rule))))) + (def (fix-template-name source start) + (let ([len (string-length source)]) + (cond + [(and (< (+ start 4) len) + (char=? (string-ref source (+ start 1)) #\.) + (char=? (string-ref source (+ start 2)) #\.) + (char=? (string-ref source (+ start 3)) #\.) + (char-alphabetic? (string-ref source (+ start 4)))) + (let loop ([i (+ start 5)]) + (if (and (< i len) + (or (char-alphabetic? (string-ref source i)) + (char-numeric? (string-ref source i)) + (char=? (string-ref source i) #\_))) + (loop (+ i 1)) + (values (substring source (+ start 4) i) i)))] + [(and (< (+ start 1) len) + (or (char-alphabetic? (string-ref source (+ start 1))) + (char=? (string-ref source (+ start 1)) #\_))) + (let loop ([i (+ start 2)]) + (if (and (< i len) + (or (char-alphabetic? (string-ref source i)) + (char-numeric? (string-ref source i)) + (char=? (string-ref source i) #\_))) + (loop (+ i 1)) + (values (substring source (+ start 1) i) i)))] + [(and (< (+ start 1) len) + (char-numeric? (string-ref source (+ start 1)))) + (let loop ([i (+ start 2)]) + (if (and (< i len) (char-numeric? (string-ref source i))) + (loop (+ i 1)) + (values (substring source (+ start 1) i) i)))] + [else (values #f (+ start 1))]))) + (def (render-fix-template template bindings) + (let ([len (string-length template)]) + (let loop ([i 0] [acc '()]) + (cond + [(= i len) (list->string (reverse acc))] + [(substring-at? template "value($" i) + (let-values ([(name next) + (fix-template-name template (+ i 6))]) + (if (and name + (< next len) + (char=? (string-ref template next) #\))) + (let* ([binding (assoc name bindings)] + [text (and binding + (metavariable-binding-text + (cdr binding)))] + [number (and text + (parse-number-literal text #f))] + [replacement (if number + (number->string number) + "")]) + (loop + (+ next 1) + (append (reverse (string->list replacement)) acc))) + (loop (+ i 1) (cons (string-ref template i) acc))))] + [(char=? (string-ref template i) #\$) + (let-values ([(name next) (fix-template-name template i)]) + (let ([binding (and name (assoc name bindings))]) + (if binding + (loop + next + (append + (reverse + (string->list + (metavariable-binding-text (cdr binding)))) + acc)) + (loop (+ i 1) (cons (string-ref template i) acc)))))] + [else (loop (+ i 1) (cons (string-ref template i) acc))])))) + (def (replace-regex-count + regex-source + text + replacement + count) + (cond + [(not count) (re-replace-all regex-source text replacement)] + [(and (number? count) (<= count 0)) text] + [(number? count) + (let loop ([remaining count] [current text]) + (if (<= remaining 0) + current + (let ([next (re-replace regex-source current replacement)]) + (if (string=? next current) + current + (loop (- remaining 1) next)))))] + [else + (error 'scan-string + "fix-regex count must be a number" + count)])) + (def (render-fix-regex spec match-text) + (replace-regex-count + (alist-ref/default spec 'regex "") + match-text + (alist-ref/default spec 'replacement "") + (alist-ref/default spec 'count #f))) + (def (finding-fix-for-match rule bindings match-text) + (cond + [(rule-fix rule) + (render-fix-template (rule-fix rule) bindings)] + [(rule-fix-regex rule) + (render-fix-regex (rule-fix-regex rule) match-text)] + [else #f])) + (define internal-match-range-name "__sg_match_range") + (define internal-resolved-decomposition-name + "__sg_resolved_decomposition") + (def (internal-binding-entry? entry) + (or (string=? (car entry) internal-match-range-name) + (string=? + (car entry) + internal-resolved-decomposition-name))) + (def (resolved-decomposition-extra bindings) + (let ([marker (assoc + internal-resolved-decomposition-name + bindings)]) + (if marker + (list + (cons + 'resolved-decomposition-vars + (metavariable-binding-text (cdr marker)))) + '()))) + (def (public-bindings bindings) + (let loop ([xs bindings] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [(internal-binding-entry? (car xs)) (loop (cdr xs) acc)] + [else (loop (cdr xs) (cons (car xs) acc))]))) + (def (finding-extra-for-match rule bindings match-text) + (let* ([visible-bindings (public-bindings bindings)] + [fix (finding-fix-for-match + rule + visible-bindings + match-text)]) + (append + (base-finding-extra rule) + (resolved-decomposition-extra bindings) + (if (null? visible-bindings) + '() + (list (cons 'metavars visible-bindings))) + (if fix (list (cons 'fix fix)) '())))) + (def (finding-extra-for-bindings rule bindings) + (finding-extra-for-match rule bindings "")) + (def (focus-binding-from-list focuses bindings) + (let loop ([focuses focuses]) + (cond + [(null? focuses) #f] + [else + (let ([binding (lookup-metavariable-binding + (car focuses) + bindings)]) + (if binding binding (loop (cdr focuses))))]))) + (def (focus-binding rule bindings) + (focus-binding-from-list + (rule-focus-metavariable rule) + bindings)) + (def (apply-rule-focus rule finding) (list finding))) --- a/lib/semgrep/scan.sls +++ b/lib/semgrep/scan.sls @@ -16,10 +16,12 @@ (except (jerboa prelude) meta atom?) (std regex) (tree-sitter tree-sitter) (semgrep lang) (semgrep rule) (semgrep result) (semgrep result builders) - (semgrep result findings) (semgrep engine rule-plan) + (semgrep result extras) (semgrep result findings) + (semgrep engine regex-scan) (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)) + (semgrep targeting path-filter) (semgrep util literals) + (semgrep match structural)) (def (alist-ref/default xs key default) (let ([found (assoc key xs)]) (if found (cdr found) default))) @@ -46,293 +48,6 @@ [(null? xs) '()] [(eq? target (car xs)) (cdr xs)] [else (cons (car xs) (remove-first-eq target (cdr xs)))])) - (def (finding-from-match rule path source match) - (let ([start (re-match-start match)] - [end (re-match-end match)]) - (let-values ([(start-line start-col) - (offset->line-col source start)] - [(end-line end-col) (offset->line-col source end)]) - (make-finding (rule-id rule) path start-line start-col end-line end-col - start end (rule-message rule) (rule-severity rule) - (finding-extra-for-match - rule - '() - (substring source start end)))))) - (def (finding-from-regex-match-at rule path source pattern - match input-start) - (let* ([start (+ input-start (re-match-start match))] - [end (+ input-start (re-match-end match))] - [bindings (regex-capture-bindings-at - pattern - source - match - input-start)]) - (let-values ([(start-line start-col) - (offset->line-col source start)] - [(end-line end-col) (offset->line-col source end)]) - (make-finding (rule-id rule) path start-line start-col end-line end-col - start end (render-fix-template (rule-message rule) bindings) - (rule-severity rule) - (finding-extra-for-match - rule - bindings - (substring source start end)))))) - (def (finding-from-regex-match rule path source pattern - match) - (finding-from-regex-match-at rule path source pattern match - 0)) - (def (finding-for-whole-text rule path source) - (let ([end (string-length source)]) - (let-values ([(end-line end-col) - (offset->line-col source end)]) - (make-finding (rule-id rule) path 1 1 end-line end-col 0 end - (rule-message rule) (rule-severity rule) - (finding-extra-for-match rule '() source))))) - (def (base-finding-extra rule) - (if (null? (rule-metadata rule)) - '() - (list (cons 'metadata (rule-metadata rule))))) - (def (fix-template-name source start) - (let ([len (string-length source)]) - (cond - [(and (< (+ start 4) len) - (char=? (string-ref source (+ start 1)) #\.) - (char=? (string-ref source (+ start 2)) #\.) - (char=? (string-ref source (+ start 3)) #\.) - (char-alphabetic? (string-ref source (+ start 4)))) - (let loop ([i (+ start 5)]) - (if (and (< i len) - (or (char-alphabetic? (string-ref source i)) - (char-numeric? (string-ref source i)) - (char=? (string-ref source i) #\_))) - (loop (+ i 1)) - (values (substring source (+ start 4) i) i)))] - [(and (< (+ start 1) len) - (or (char-alphabetic? (string-ref source (+ start 1))) - (char=? (string-ref source (+ start 1)) #\_))) - (let loop ([i (+ start 2)]) - (if (and (< i len) - (or (char-alphabetic? (string-ref source i)) - (char-numeric? (string-ref source i)) - (char=? (string-ref source i) #\_))) - (loop (+ i 1)) - (values (substring source (+ start 1) i) i)))] - [(and (< (+ start 1) len) - (char-numeric? (string-ref source (+ start 1)))) - (let loop ([i (+ start 2)]) - (if (and (< i len) (char-numeric? (string-ref source i))) - (loop (+ i 1)) - (values (substring source (+ start 1) i) i)))] - [else (values #f (+ start 1))]))) - (def (render-fix-template template bindings) - (let ([len (string-length template)]) - (let loop ([i 0] [acc '()]) - (cond - [(= i len) (list->string (reverse acc))] - [(substring-at? template "value($" i) - (let-values ([(name next) - (fix-template-name template (+ i 6))]) - (if (and name - (< next len) - (char=? (string-ref template next) #\))) - (let* ([binding (assoc name bindings)] - [text (and binding - (metavariable-binding-text - (cdr binding)))] - [number (and text - (parse-number-literal text #f))] - [replacement (if number - (number->string number) - "")]) - (loop - (+ next 1) - (append (reverse (string->list replacement)) acc))) - (loop (+ i 1) (cons (string-ref template i) acc))))] - [(char=? (string-ref template i) #\$) - (let-values ([(name next) (fix-template-name template i)]) - (let ([binding (and name (assoc name bindings))]) - (if binding - (loop - next - (append - (reverse - (string->list - (metavariable-binding-text (cdr binding)))) - acc)) - (loop (+ i 1) (cons (string-ref template i) acc)))))] - [else (loop (+ i 1) (cons (string-ref template i) acc))])))) - (def (replace-regex-count - regex-source - text - replacement - count) - (cond - [(not count) (re-replace-all regex-source text replacement)] - [(and (number? count) (<= count 0)) text] - [(number? count) - (let loop ([remaining count] [current text]) - (if (<= remaining 0) - current - (let ([next (re-replace regex-source current replacement)]) - (if (string=? next current) - current - (loop (- remaining 1) next)))))] - [else - (error 'scan-string - "fix-regex count must be a number" - count)])) - (def (render-fix-regex spec match-text) - (replace-regex-count - (alist-ref/default spec 'regex "") - match-text - (alist-ref/default spec 'replacement "") - (alist-ref/default spec 'count #f))) - (def (finding-fix-for-match rule bindings match-text) - (cond - [(rule-fix rule) - (render-fix-template (rule-fix rule) bindings)] - [(rule-fix-regex rule) - (render-fix-regex (rule-fix-regex rule) match-text)] - [else #f])) - (define internal-match-range-name "__sg_match_range") - (define internal-resolved-decomposition-name - "__sg_resolved_decomposition") - (def (internal-binding-entry? entry) - (or (string=? (car entry) internal-match-range-name) - (string=? - (car entry) - internal-resolved-decomposition-name))) - (def (resolved-decomposition-extra bindings) - (let ([marker (assoc - internal-resolved-decomposition-name - bindings)]) - (if marker - (list - (cons - 'resolved-decomposition-vars - (metavariable-binding-text (cdr marker)))) - '()))) - (def (public-bindings bindings) - (let loop ([xs bindings] [acc '()]) - (cond - [(null? xs) (reverse acc)] - [(internal-binding-entry? (car xs)) (loop (cdr xs) acc)] - [else (loop (cdr xs) (cons (car xs) acc))]))) - (def (finding-extra-for-match rule bindings match-text) - (let* ([visible-bindings (public-bindings bindings)] - [fix (finding-fix-for-match - rule - visible-bindings - match-text)]) - (append - (base-finding-extra rule) - (resolved-decomposition-extra bindings) - (if (null? visible-bindings) - '() - (list (cons 'metavars visible-bindings))) - (if fix (list (cons 'fix fix)) '())))) - (def (finding-extra-for-bindings rule bindings) - (finding-extra-for-match rule bindings "")) - (def (focus-binding-from-list focuses bindings) - (let loop ([focuses focuses]) - (cond - [(null? focuses) #f] - [else - (let ([binding (lookup-metavariable-binding - (car focuses) - bindings)]) - (if binding binding (loop (cdr focuses))))]))) - (def (focus-binding rule bindings) - (focus-binding-from-list - (rule-focus-metavariable rule) - bindings)) - (def (apply-rule-focus rule finding) (list finding)) - (def (scan-regex-pattern rule path source pattern) - (let ([rx (re (regex-pattern-for-engine pattern))] - [len (string-length source)]) - (let loop ([start 0] [acc '()]) - (if (> start len) - (reverse acc) - (let ([match (re-search rx source start)]) - (if match - (let* ([finding (finding-from-regex-match rule path - source pattern match)] - [next (max (+ (re-match-start match) 1) - (re-match-end match))]) - (loop - next - (append - (reverse (apply-rule-focus rule finding)) - acc))) - (reverse acc))))))) - (def (regex-uses-line-anchor? pattern) - (let ([len (string-length pattern)]) - (let loop ([i 0] [escaped? #f]) - (cond - [(= i len) #f] - [escaped? (loop (+ i 1) #f)] - [(char=? (string-ref pattern i) #\\) (loop (+ i 1) #t)] - [(or (char=? (string-ref pattern i) #\^) - (char=? (string-ref pattern i) #\$)) - #t] - [else (loop (+ i 1) #f)])))) - (def (scan-regex-pattern-line rule path source pattern line - line-start) - (let ([rx (re (regex-pattern-for-engine pattern))] - [len (string-length line)]) - (let loop ([start 0] [acc '()]) - (if (> start len) - (reverse acc) - (let ([match (re-search rx line start)]) - (if match - (let* ([finding (finding-from-regex-match-at rule path source pattern match - line-start)] - [next (max (+ (re-match-start match) 1) - (re-match-end match))]) - (loop - next - (append - (reverse (apply-rule-focus rule finding)) - acc))) - (reverse acc))))))) - (def (scan-regex-pattern-lines rule path source pattern) - (let ([len (string-length source)]) - (let loop ([i 0] [line-start 0] [acc '()]) - (cond - [(= i len) - (reverse - (append - (reverse - (scan-regex-pattern-line rule path source pattern - (substring source line-start len) line-start)) - acc))] - [(char=? (string-ref source i) #\newline) - (loop - (+ i 1) - (+ i 1) - (append - (reverse - (scan-regex-pattern-line rule path source pattern - (substring source line-start i) line-start)) - acc))] - [else (loop (+ i 1) line-start acc)])))) - (def (scan-regex-pattern-with-line-anchors - rule - path - source - pattern) - (if (regex-uses-line-anchor? pattern) - (dedupe-findings - (append - (scan-regex-pattern rule path source pattern) - (scan-regex-pattern-lines rule path source pattern))) - (scan-regex-pattern rule path source pattern))) - (def (scan-regex-rule rule path source) - (scan-regex-pattern-with-line-anchors - rule - path - source - (rule-pattern rule))) (def (generic-language? language) (let ([canonical (or (canonical-language language) language)]) @@ -27471,16 +27186,6 @@ [(> i len) #f] [(substring-at? s needle i) i] [else (loop (+ i 1))])))) - (def (quoted-string? s) - (and (>= (string-length s) 2) - (or (and (char=? (string-ref s 0) #\") - (char=? (string-ref s (- (string-length s) 1)) #\")) - (and (char=? (string-ref s 0) #\') - (char=? - (string-ref s (- (string-length s) 1)) - #\'))))) - (def (unquote-string s) - (substring s 1 (- (string-length s) 1))) (define missing-comparison-value (list 'missing-comparison-value)) (def (comparison-missing? value) @@ -27698,90 +27403,6 @@ [(comparison-identifier-char? (string-ref expr i)) (loop (+ i 1))] [else #f]))))))) - (def (strip-number-suffix s) - (let ([len (string-length s)]) - (if (and (> len 1) - (let ([ch (string-ref s (- len 1))]) - (or (char=? ch #\f) - (char=? ch #\F) - (char=? ch #\d) - (char=? ch #\D) - (char=? ch #\l) - (char=? ch #\L)))) - (substring s 0 (- len 1)) - s))) - (def (remove-number-underscores s) - (let ([len (string-length s)]) - (let loop ([i 0] [acc '()]) - (cond - [(= i len) (list->string (reverse acc))] - [(char=? (string-ref s i) #\_) (loop (+ i 1) acc)] - [else (loop (+ i 1) (cons (string-ref s i) acc))])))) - (def (digit-value ch) - (cond - [(and (char>=? ch #\0) (char<=? ch #\9)) - (- (char->integer ch) (char->integer #\0))] - [(and (char>=? ch #\a) (char<=? ch #\z)) - (+ 10 (- (char->integer ch) (char->integer #\a)))] - [(and (char>=? ch #\A) (char<=? ch #\Z)) - (+ 10 (- (char->integer ch) (char->integer #\A)))] - [else #f])) - (def (parse-integer-digits source base) - (let ([len (string-length source)]) - (and (> len 0) - (let loop ([i 0] [acc 0]) - (if (= i len) - acc - (let ([digit (digit-value (string-ref source i))]) - (and digit - (< digit base) - (loop (+ i 1) (+ (* acc base) digit))))))))) - (def (strip-delimiter-pair s) - (if (quoted-string? s) (unquote-string s) s)) - (def (parse-number-literal value base) - (let* ([trimmed (strip-delimiter-pair (string-trim value))] - [clean (remove-number-underscores - (strip-number-suffix trimmed))] - [len (string-length clean)]) - (if (= len 0) - #f - (let-values ([(sign body) - (cond - [(char=? (string-ref clean 0) #\-) - (values -1 (substring clean 1 len))] - [(char=? (string-ref clean 0) #\+) - (values 1 (substring clean 1 len))] - [else (values 1 clean)])]) - (let ([body-len (string-length body)]) - (cond - [(and (number? base) (parse-integer-digits body base)) => - (lambda (n) (* sign n))] - [(and (>= body-len 3) - (char=? (string-ref body 0) #\0) - (or (char=? (string-ref body 1) #\x) - (char=? (string-ref body 1) #\X)) - (parse-integer-digits - (substring body 2 body-len) - 16)) => - (lambda (n) (* sign n))] - [(and (>= body-len 3) - (char=? (string-ref body 0) #\0) - (or (char=? (string-ref body 1) #\o) - (char=? (string-ref body 1) #\O)) - (parse-integer-digits - (substring body 2 body-len) - 8)) => - (lambda (n) (* sign n))] - [(and (>= body-len 3) - (char=? (string-ref body 0) #\0) - (or (char=? (string-ref body 1) #\b) - (char=? (string-ref body 1) #\B)) - (parse-integer-digits - (substring body 2 body-len) - 2)) => - (lambda (n) (* sign n))] - [(string->number clean) => values] - [else #f])))))) (def (comparison-value->string value) (cond [(comparison-missing? value) ""] new file mode 100644 --- /dev/null +++ b/lib/semgrep/util/literals.sls @@ -0,0 +1,107 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/semgrep/util/literals.ss + +(library (semgrep util literals) + (export quoted-string? unquote-string strip-delimiter-pair + parse-integer-digits parse-number-literal) + (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?)) + (def (quoted-string? s) + (and (>= (string-length s) 2) + (or (and (char=? (string-ref s 0) #\") + (char=? (string-ref s (- (string-length s) 1)) #\")) + (and (char=? (string-ref s 0) #\') + (char=? + (string-ref s (- (string-length s) 1)) + #\'))))) + (def (unquote-string s) + (substring s 1 (- (string-length s) 1))) + (def (strip-number-suffix s) + (let ([len (string-length s)]) + (if (and (> len 1) + (let ([ch (string-ref s (- len 1))]) + (or (char=? ch #\f) + (char=? ch #\F) + (char=? ch #\d) + (char=? ch #\D) + (char=? ch #\l) + (char=? ch #\L)))) + (substring s 0 (- len 1)) + s))) + (def (remove-number-underscores s) + (let ([len (string-length s)]) + (let loop ([i 0] [acc '()]) + (cond + [(= i len) (list->string (reverse acc))] + [(char=? (string-ref s i) #\_) (loop (+ i 1) acc)] + [else (loop (+ i 1) (cons (string-ref s i) acc))])))) + (def (digit-value ch) + (cond + [(and (char>=? ch #\0) (char<=? ch #\9)) + (- (char->integer ch) (char->integer #\0))] + [(and (char>=? ch #\a) (char<=? ch #\z)) + (+ 10 (- (char->integer ch) (char->integer #\a)))] + [(and (char>=? ch #\A) (char<=? ch #\Z)) + (+ 10 (- (char->integer ch) (char->integer #\A)))] + [else #f])) + (def (parse-integer-digits source base) + (let ([len (string-length source)]) + (and (> len 0) + (let loop ([i 0] [acc 0]) + (if (= i len) + acc + (let ([digit (digit-value (string-ref source i))]) + (and digit + (< digit base) + (loop (+ i 1) (+ (* acc base) digit))))))))) + (def (strip-delimiter-pair s) + (if (quoted-string? s) (unquote-string s) s)) + (def (parse-number-literal value base) + (let* ([trimmed (strip-delimiter-pair (string-trim value))] + [clean (remove-number-underscores + (strip-number-suffix trimmed))] + [len (string-length clean)]) + (if (= len 0) + #f + (let-values ([(sign body) + (cond + [(char=? (string-ref clean 0) #\-) + (values -1 (substring clean 1 len))] + [(char=? (string-ref clean 0) #\+) + (values 1 (substring clean 1 len))] + [else (values 1 clean)])]) + (let ([body-len (string-length body)]) + (cond + [(and (number? base) (parse-integer-digits body base)) => + (lambda (n) (* sign n))] + [(and (>= body-len 3) + (char=? (string-ref body 0) #\0) + (or (char=? (string-ref body 1) #\x) + (char=? (string-ref body 1) #\X)) + (parse-integer-digits + (substring body 2 body-len) + 16)) => + (lambda (n) (* sign n))] + [(and (>= body-len 3) + (char=? (string-ref body 0) #\0) + (or (char=? (string-ref body 1) #\o) + (char=? (string-ref body 1) #\O)) + (parse-integer-digits + (substring body 2 body-len) + 8)) => + (lambda (n) (* sign n))] + [(and (>= body-len 3) + (char=? (string-ref body 0) #\0) + (or (char=? (string-ref body 1) #\b) + (char=? (string-ref body 1) #\B)) + (parse-integer-digits + (substring body 2 body-len) + 2)) => + (lambda (n) (* sign n))] + [(string->number clean) => values] + [else #f]))))))) --- a/src/.jerbuild-hashes +++ b/src/.jerbuild-hashes @@ -1,19 +1,23 @@ -(("src/semgrep/output/sarif.ss" . "E935456E4B1921FB") ("src/semgrep/result.ss" . "22D23E40B49BA529") - ("src/semgrep/engine/rule-plan.ss" . "6631789392AB5F80") - ("src/semgrep/result/findings.ss" . "547811661239D9C7") - ("src/semgrep/fix.ss" . "2E5B65B1FEF3B2B1") - ("src/semgrep/match/structural.ss" . "5BA4F1566448AF3A") - ("src/semgrep/targeting/path-filter.ss" . "9900721941C6B96") - ("src/semgrep/rule/parse-rule.ss" . "EFA6D401699CEDEF") - ("src/semgrep/output/json.ss" . "293881CFA2ADB7BC") - ("src/semgrep/lang.ss" . "6982E07679D20836") - ("src/semgrep/parse/parse-target.ss" . "97AA8FFEB12736DA") - ("src/semgrep/scan.ss" . "F056CECD5465287C") - ("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/result/builders.ss" . "93A64AF4435E6132") - ("src/semgrep/cli.ss" . "EBDC4B1DAD3F13CC")) +(("src/semgrep/output/sarif.ss" . "E935456E4B1921FB") + ("src/semgrep/engine/regex-scan.ss" . "D75414F0AEFE2F66") + ("src/semgrep/result.ss" . "22D23E40B49BA529") + ("src/semgrep/engine/rule-plan.ss" . "6631789392AB5F80") + ("src/semgrep/result/findings.ss" . "547811661239D9C7") + ("src/semgrep/util/literals.ss" . "8A094085551B216E") + ("src/semgrep/fix.ss" . "2E5B65B1FEF3B2B1") + ("src/semgrep/match/structural.ss" . "5BA4F1566448AF3A") + ("src/semgrep/targeting/path-filter.ss" . "9900721941C6B96") + ("src/semgrep/rule/parse-rule.ss" . "EFA6D401699CEDEF") + ("src/semgrep/output/json.ss" . "293881CFA2ADB7BC") + ("src/semgrep/lang.ss" . "6982E07679D20836") + ("src/semgrep/parse/parse-target.ss" . "97AA8FFEB12736DA") + ("src/semgrep/result/extras.ss" . "DF0B3AAE2BAEB5D") + ("src/semgrep/scan.ss" . "A2521D6C86290D1C") + ("src/semgrep/output/text.ss" . "BE476CB84B807FBA") + ("src/semgrep/rule.ss" . "E12C108153C181FA") + ("src/semgrep/schema/lang.ss" . "CAE2CA859C9A9FD0") + ("src/semgrep/source/offsets.ss" . "834EFDB706823794") + ("src/semgrep/engine/regex-support.ss" . "9FCF118903259C97") + ("src/semgrep/main.ss" . "A4EC9E7F2A09D25E") + ("src/semgrep/result/builders.ss" . "93A64AF4435E6132") + ("src/semgrep/cli.ss" . "EBDC4B1DAD3F13CC")) new file mode 100644 --- /dev/null +++ b/src/semgrep/engine/regex-scan.ss @@ -0,0 +1,173 @@ +(export + finding-from-match + finding-for-whole-text + scan-regex-pattern-with-line-anchors + scan-regex-rule) + +(import (except (jerboa prelude) meta atom?) + (std regex) + (semgrep rule) + (semgrep result) + (semgrep result extras) + (semgrep result findings) + (semgrep engine regex-support) + (semgrep source offsets)) + +(def (finding-from-match rule path source match) + (let ([start (re-match-start match)] + [end (re-match-end match)]) + (let-values ([(start-line start-col) (offset->line-col source start)] + [(end-line end-col) (offset->line-col source end)]) + (make-finding + (rule-id rule) + path + start-line + start-col + end-line + end-col + start + end + (rule-message rule) + (rule-severity rule) + (finding-extra-for-match + rule + '() + (substring source start end)))))) + +(def (finding-from-regex-match-at rule path source pattern match input-start) + (let* ([start (+ input-start (re-match-start match))] + [end (+ input-start (re-match-end match))] + [bindings (regex-capture-bindings-at pattern source match input-start)]) + (let-values ([(start-line start-col) (offset->line-col source start)] + [(end-line end-col) (offset->line-col source end)]) + (make-finding + (rule-id rule) + path + start-line + start-col + end-line + end-col + start + end + (render-fix-template (rule-message rule) bindings) + (rule-severity rule) + (finding-extra-for-match + rule + bindings + (substring source start end)))))) + +(def (finding-from-regex-match rule path source pattern match) + (finding-from-regex-match-at rule path source pattern match 0)) + +(def (finding-for-whole-text rule path source) + (let ([end (string-length source)]) + (let-values ([(end-line end-col) (offset->line-col source end)]) + (make-finding + (rule-id rule) + path + 1 + 1 + end-line + end-col + 0 + end + (rule-message rule) + (rule-severity rule) + (finding-extra-for-match rule '() source))))) + +(def (scan-regex-pattern rule path source pattern) + (let ([rx (re (regex-pattern-for-engine pattern))] + [len (string-length source)])