Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Add old ABNF-PPCRE code.

Signed-off-by: Stelian Ionescu <sionescu@common-lisp.net>
  • Loading branch information...
commit ecaddc3de6222db5e6d831988cae0b29d53fa29d 1 parent 8575e3f
Stelian Ionescu authored August 20, 2008 sionescu committed February 05, 2014
111  base/abnf-ppcre.lisp
... ...
@@ -0,0 +1,111 @@
  1
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
  2
+
  3
+(cl:defpackage :iolib-utils.abnf-pcre
  4
+    (:use :cl :alexandria)
  5
+  (:export #:define-abnf-syntax))
  6
+
  7
+(in-package :iolib-utils.abnf-pcre)
  8
+
  9
+(declaim (optimize (debug 3)))
  10
+
  11
+(defparameter *default-non-terminals*
  12
+  (alexandria:alist-hash-table
  13
+   '((:digit . (:range #\0 #\9))
  14
+     (:hexdig . (:or (:range #\0 #\9) (:range #\a #\f) (:range #\A #\F)))
  15
+     (:alpha . (:or (:range #\a #\z) (:range #\A #\Z))))
  16
+   :test #'eq))
  17
+
  18
+(defvar *non-terminals* nil)
  19
+(defvar *non-terminals-normalized* nil)
  20
+
  21
+(defgeneric normalize-expression* (op expr))
  22
+(defgeneric encode-expression* (op args))
  23
+
  24
+;;;
  25
+;;; Normalizing
  26
+;;;
  27
+
  28
+(defun only-char-elems-p (expr)
  29
+  (loop :for e :in expr
  30
+        :always (or (and (stringp e) (= 1 (length e)))
  31
+                    (and (consp e) (eql :range (car e))))))
  32
+
  33
+(defun normalize-expression (expr)
  34
+  (etypecase expr
  35
+    (cons (normalize-expression* (car expr) expr))
  36
+    (keyword (gethash expr *default-non-terminals*))
  37
+    (symbol (cond ((gethash expr *non-terminals-normalized*)
  38
+                   (gethash expr *non-terminals*))
  39
+                  (t
  40
+                   (setf (gethash expr *non-terminals*)
  41
+                         (normalize-expression (gethash expr *non-terminals*)))
  42
+                   (setf (gethash expr *non-terminals-normalized*) t))))
  43
+    ((or string character) expr)))
  44
+
  45
+(defmacro define-normalizer (operator (&rest args) &body body)
  46
+  `(defmethod normalize-expression* ((op (eql ,operator)) ,@args)
  47
+     ,@body))
  48
+
  49
+(define-normalizer :range (expr)
  50
+  (destructuring-bind (from to) (cdr expr)
  51
+    (check-type from character)
  52
+    (check-type to character)
  53
+    (assert (<= (char-code from) (char-code to)))
  54
+    `(:range ,from ,to)))
  55
+
  56
+(define-normalizer :any (expr)
  57
+  (destructuring-bind (arg) (cdr expr)
  58
+    `(:repeat (0) ,(normalize-expression arg))))
  59
+
  60
+(define-normalizer :req (expr)
  61
+  (destructuring-bind (arg) (cdr expr)
  62
+    `(:repeat (1) ,(normalize-expression arg))))
  63
+
  64
+(define-normalizer :opt (expr)
  65
+  (destructuring-bind (arg) (cdr expr)
  66
+    `(:repeat (0 1) ,(normalize-expression arg))))
  67
+
  68
+(define-normalizer :repeat (expr)
  69
+  (destructuring-bind (params args) (cdr expr)
  70
+    (ecase (car params)
  71
+      (:= (destructuring-bind (val) (cdr params)
  72
+            (check-type val unsigned-byte)
  73
+            `(:repeat (,val ,val) ,(normalize-expression args))))
  74
+      (:from (destructuring-bind (from &optional to) (cdr params)
  75
+               (check-type from unsigned-byte)
  76
+               (check-type to (or null unsigned-byte))
  77
+               `(:repeat (,from ,to) ,(normalize-expression args))))
  78
+      (:to (destructuring-bind (val) (cdr params)
  79
+             (check-type val unsigned-byte)
  80
+             `(:repeat (0 ,val) ,(normalize-expression args)))))))
  81
+
  82
+(define-normalizer :or (expr)
  83
+  expr)
  84
+
  85
+(define-normalizer :not (expr)
  86
+  (normalize-expression `(:or :not ,@(cdr expr))))
  87
+
  88
+(define-normalizer :conc (expr)
  89
+  (list* :conc (mapcar #'normalize-expression (cdr expr))))
  90
+
  91
+(defmethod normalize-expression* (op expr)
  92
+  (normalize-expression (list* :conc expr)))
  93
+
  94
+;;;
  95
+;;; Encoding
  96
+;;;
  97
+
  98
+(defun encode-expression (expr)
  99
+  (let ((e (normalize-expression expr)))
  100
+    (encode-expression* (car e) (cdr e))))
  101
+
  102
+(defmacro define-encoder (operator (&rest args) &body body)
  103
+  `(defmethod encode-expression* ((op (eql ,operator)) ,@args)
  104
+     ,@body))
  105
+
  106
+(define-encoder :range (args)
  107
+  (destructuring-bind (from to) args
  108
+    (format t "[~A-~A]" from to)))
  109
+
  110
+(defmacro define-abnf-syntax (name &body clauses)
  111
+  )
12  io.uri.asd
... ...
@@ -0,0 +1,12 @@
  1
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
  2
+
  3
+(asdf:defsystem :io.uri
  4
+  :description "URI library."
  5
+  :author "Stelian Ionescu <sionescu@common-lisp.net>"
  6
+  :maintainer "Stelian Ionescu <sionescu@common-lisp.net>"
  7
+  :licence "MIT"
  8
+  :depends-on (:iolib.base :babel :cl-ppcre)
  9
+  :pathname (merge-pathnames #p"io.uri/" *load-truename*)
  10
+  :components
  11
+  ((:file "pkgdcl")
  12
+   (:file "uri" :depends-on ("pkgdcl"))))
10  io.uri/pkgdcl.lisp
... ...
@@ -0,0 +1,10 @@
  1
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
  2
+;;;
  3
+;;; --- Package definition.
  4
+;;;
  5
+
  6
+(in-package :common-lisp-user)
  7
+
  8
+(defpackage :io.uri
  9
+  (:use :iolib.base :babel :cl-ppcre)
  10
+  (:export))
114  io.uri/uri.lisp
... ...
@@ -0,0 +1,114 @@
  1
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
  2
+;;;
  3
+;;; --- Parsing URIs.
  4
+;;;
  5
+
  6
+(in-package :io.uri)
  7
+
  8
+(defmacro register-bind ((&rest bindings) (regex target-string &key (start 0) end) &body body)
  9
+  (flet ((compute-bindings (fun)
  10
+           (loop :for index :from 0 :for b :in bindings
  11
+                 :if (string/= b "_") :collect `(,b (,fun ,index)))))
  12
+    (with-gensyms (string match-start match-end registers-start registers-end register-fun)
  13
+      (let ((bindings (compute-bindings register-fun)))
  14
+        `(let ((,string ,target-string))
  15
+           (multiple-value-bind (,match-start ,match-end ,registers-start ,registers-end)
  16
+               (scan ,regex ,string :start ,start :end (or ,end (length ,string)))
  17
+             (declare (ignore ,match-end))
  18
+             (flet ((,register-fun (index)
  19
+                      (when ,match-start
  20
+                        (let ((start (aref ,registers-start index))
  21
+                              (end (aref ,registers-end index)))
  22
+                          (when start (subseq ,string start end))))))
  23
+               (let ,bindings
  24
+                 (declare (ignorable ,@(mapcar #'car bindings)))
  25
+                 ,@body))))))))
  26
+
  27
+(define-constant +uri-regexp+
  28
+    "^<?(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\\?([^#]*))?(#(.*))?>?$"
  29
+  :test #'string=)
  30
+
  31
+(defun %parse-uri (uri)
  32
+  (multiple-value-bind (start end svec evec)
  33
+      (scan +uri-regexp+ uri)
  34
+    (declare (ignore end))
  35
+    (flet ((reg (index)
  36
+             (let ((s (aref svec index))
  37
+                   (e (aref evec index)))
  38
+               (when s (subseq uri s e)))))
  39
+      (when start
  40
+        (values (reg 1) (reg 3) (reg 4) (reg 6) (reg 8))))))
  41
+
  42
+(defparameter +userinfo-regexp+ "(((%[0-9a-fA-F]{2}|[-$!&'()*+,;=:a-zA-Z0-9._~])*)@)?")
  43
+(defparameter +host-regexp+ "([-~a-zA-Z0-9]+|\\[.*:.*:.*\\])")
  44
+(defparameter +port-regexp+ "(:([0-9]*))?")
  45
+(defparameter +authority-regexp+
  46
+  (concatenate 'string +userinfo-regexp+ +host-regexp+ +port-regexp+))
  47
+
  48
+(defun %parse-authority (authority)
  49
+  (multiple-value-bind (start end svec evec)
  50
+      (scan +authority-regexp+ authority)
  51
+    (declare (ignore end))
  52
+    (flet ((reg (index)
  53
+             (let ((s (aref svec index))
  54
+                   (e (aref evec index)))
  55
+               (when s (subseq authority s e)))))
  56
+      (when start
  57
+        (values (reg 1) (reg 3) (reg 5))))))
  58
+
  59
+(define-abnf-syntax :uri
  60
+  (uri . (scheme ":" hier-part (:opt ("?" query)) (:opt ("#" fragment))))
  61
+  (hier-part . (:or ("//" authority path-abempty) path-absolute path-rootless path-empty))
  62
+  (uri-reference . (:or uri relative-ref))
  63
+  (absolute-uri . (scheme ":" hier-part (:opt ("?" query))))
  64
+  (relative-ref . (relative-part (:opt ("?" query)) (:opt ("#" fragment))))
  65
+  (relative-part . (:or ("//" authority path-abempty) path-absolute path-noscheme path-empty))
  66
+  (scheme . (:alpha (:any (:or :alpha :digit "+" "-" "."))))
  67
+  (authority . ((:opt (userinfo "@")) host (:opt (":" port))))
  68
+  (userinfo . (:any (:or unreserved pct-encoded sub-delims ":")))
  69
+  (host . (:or ip-literal ipv4-address reg-name))
  70
+  (port . (:any :digit))
  71
+  (ip-literal . ("[" (:or ipv6address ipvfuture) "]"))
  72
+  (ipvfuture . ("v" (:req :hexdig) "." (:req (:or unreserved sub-delims ":"))))
  73
+  (ipv6address . (:or (                                               (:repeat (:= 6) (h16 ":")) ls32)
  74
+                      (                                         "::"  (:repeat (:= 5) (h16 ":")) ls32)
  75
+                      ((:opt                               h16) "::"  (:repeat (:= 4) (h16 ":")) ls32)
  76
+                      ((:opt ((:repeat (:to 1) (h16 ":")) h16)) "::"  (:repeat (:= 3) (h16 ":")) ls32)
  77
+                      ((:opt ((:repeat (:to 2) (h16 ":")) h16)) "::"  (:repeat (:= 2) (h16 ":")) ls32)
  78
+                      ((:opt ((:repeat (:to 3) (h16 ":")) h16)) "::"                  (h16 ":")  ls32)
  79
+                      ((:opt ((:repeat (:to 4) (h16 ":")) h16)) "::"                             ls32)
  80
+                      ((:opt ((:repeat (:to 5) (h16 ":")) h16)) "::"                             h16)
  81
+                      ((:opt ((:repeat (:to 6) (h16 ":")) h16)) "::")))
  82
+  (h16 . (:repeat (:from 1 4) :hexdig))
  83
+  (ls32 . (:or (h16 ":" h16) ipv4address))
  84
+  (ipv4address . (dec-octet "." dec-octet "." dec-octet "." dec-octet))
  85
+  (dec-octet . (:or :digit
  86
+                    ((:range #\1 #\9) :digit)
  87
+                    ("1" (:repeat (:= 2) :digit))
  88
+                    ("2" (:range #\0 #\4) :digit)
  89
+                    ("25" (:range #\0 #\5))))
  90
+  (reg-name . (:any (:or unreserved pct-encoded sub-delims)))
  91
+  (path . (:or path-abempty path-absolute path-noscheme path-rootless path-empty))
  92
+  (path-abempty . (:any ("/" segment)))
  93
+  (path-absolute . ("/" (:opt (segment-nz (:any ("/" segment))))))
  94
+  (path-noscheme . (segment-nz-nc (:any ("/" segment))))
  95
+  (path-rootless . (segment-nz (:any ("/" segment))))
  96
+  (path-empty . (:not pchar))
  97
+  (segment . (:any pchar))
  98
+  (segment-nz . (:req pchar))
  99
+  (segment-nz-nc . (:req (:or unreserved pct-encoded sub-delims "@")))
  100
+  (pchar . (:or unreserved pct-encoded sub-delims ":" "@"))
  101
+  (query . (:any (:or pchar "/" "?")))
  102
+  (fragment . (:any (:or pchar "/" "?")))
  103
+  (pct-encoded . ("%" :hexdig :hexdig))
  104
+  (unreserved . (:or :alpha :digit "-" "." "_" "~"))
  105
+  (reserved . (:or gen-delims sub-delims))
  106
+  (gen-delims . (:or ":" "/" "?" "#" "[" "]" "@"))
  107
+  (sub-delims . (:or "!" "$" "&" "'" "(" ")" "*" "+" "," ";" "=")))
  108
+
  109
+(define-condition uri-parse-error (parse-error) ())
  110
+
  111
+(defun uri-parse-error (message &rest args)
  112
+  (error 'uri-parse-error
  113
+         :format-control message
  114
+         :format-arguments args))

0 notes on commit ecaddc3

Please sign in to comment.
Something went wrong with that request. Please try again.