1;; -*- mode: common-lisp; package: puri -*- 2;; Support for URIs 3;; For general URI information see RFC2396. 4;; 5;; copyright (c) 1999-2002 Franz Inc, Berkeley, CA - All rights reserved. 6;; copyright (c) 2002-2005 Franz Inc, Oakland, CA - All rights reserved. 7;; copyright (c) 2003-2010 Kevin Rosenberg 8;; 9;; This code is free software; you can redistribute it and/or 10;; modify it under the terms of the version 2.1 of 11;; the GNU Lesser General Public License as published by 12;; the Free Software Foundation, as clarified by the 13;; preamble found here: 14;; http://opensource.franz.com/preamble.html 15;; 16;; Versions ported from Franz's opensource release 17;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer 18;; uri.cl,v 2.9.84.1 2005/08/11 18:38:52 layer 19 20;; This code is distributed in the hope that it will be useful, 21;; but without any warranty; without even the implied warranty of 22;; merchantability or fitness for a particular purpose. See the GNU 23;; Lesser General Public License for more details. 24 25(defpackage #:puri 26 (:use #:cl) 27 #-(or allegro zacl) (:nicknames #:net.uri) 28 (:export 29 #:uri ; the type and a function 30 #:uri-p 31 #:copy-uri 32 33 #:uri-scheme ; and slots 34 #:uri-host #:uri-port 35 #:uri-path 36 #:uri-query 37 #:uri-is-ip6 38 #:uri-fragment 39 #:uri-plist 40 #:uri-authority ; pseudo-slot accessor 41 42 #:urn ; class 43 #:urn-nid ; pseudo-slot accessor 44 #:urn-nss ; pseudo-slot accessor 45 46 #:*strict-parse* 47 #:parse-uri 48 #:merge-uris 49 #:enough-uri 50 #:uri-parsed-path 51 #:render-uri 52 53 #:make-uri-space ; interning... 54 #:uri-space 55 #:uri= 56 #:intern-uri 57 #:unintern-uri 58 #:do-all-uris 59 60 #:uri-parse-error ;; Added by KMR 61 )) 62 63(in-package #:puri) 64 65(eval-when (:compile-toplevel) (declaim (optimize (speed 3)))) 66 67 68#-allegro 69(defun parse-body (forms &optional env) 70 "Parses a body, returns (VALUES docstring declarations forms)" 71 (declare (ignore env)) 72 ;; fixme -- need to add parsing of multiple declarations 73 (let (docstring declarations) 74 (when (stringp (car forms)) 75 (setq docstring (car forms)) 76 (setq forms (cdr forms))) 77 (when (and (listp (car forms)) 78 (symbolp (caar forms)) 79 (string-equal (symbol-name '#:declare) 80 (symbol-name (caar forms)))) 81 (setq declarations (car forms)) 82 (setq forms (cdr forms))) 83 (values docstring declarations forms))) 84 85 86(defun shrink-vector (str size) 87 #+allegro 88 (excl::.primcall 'sys::shrink-svector str size) 89 #+sbcl 90 (setq str (sb-kernel:shrink-vector str size)) 91 #+cmu 92 (lisp::shrink-vector str size) 93 #+lispworks 94 (system::shrink-vector$vector str size) 95 #+scl 96 (common-lisp::shrink-vector str size) 97 #-(or allegro cmu lispworks sbcl scl) 98 (setq str (subseq str 0 size)) 99 str) 100 101 102;; KMR: Added new condition to handle cross-implementation variances 103;; in the parse-error condition many implementations define 104 105(define-condition uri-parse-error (parse-error) 106 ((fmt-control :initarg :fmt-control :accessor fmt-control) 107 (fmt-arguments :initarg :fmt-arguments :accessor fmt-arguments )) 108 (:report (lambda (c stream) 109 (format stream "Parse error:") 110 (apply #'format stream (fmt-control c) (fmt-arguments c))))) 111 112(defun .parse-error (fmt &rest args) 113 (error 'uri-parse-error :fmt-control fmt :fmt-arguments args)) 114 115#-allegro 116(defun internal-reader-error (stream fmt &rest args) 117 (apply #'format stream fmt args)) 118 119#-allegro (defvar *current-case-mode* :case-insensitive-upper) 120#+allegro (eval-when (:compile-toplevel :load-toplevel :execute) 121 (import '(excl:*current-case-mode* 122 excl:delimited-string-to-list 123 excl::parse-body 124 excl::internal-reader-error 125 excl:if*))) 126 127#-allegro 128(defmethod position-char (char (string string) start max) 129 (declare (optimize (speed 3) (safety 0) (space 0)) 130 (fixnum start max) (string string)) 131 (do* ((i start (1+ i))) 132 ((= i max) nil) 133 (declare (fixnum i)) 134 (when (char= char (char string i)) (return i)))) 135 136#-allegro 137(defun delimited-string-to-list (string &optional (separator #\space) 138 skip-terminal) 139 (declare (optimize (speed 3) (safety 0) (space 0) 140 (compilation-speed 0)) 141 (type string string) 142 (type character separator)) 143 (do* ((len (length string)) 144 (output '()) 145 (pos 0) 146 (end (position-char separator string pos len) 147 (position-char separator string pos len))) 148 ((null end) 149 (if (< pos len) 150 (push (subseq string pos) output) 151 (when (and (plusp len) (not skip-terminal)) 152 (push "" output))) 153 (nreverse output)) 154 (declare (type fixnum pos len) 155 (type (or null fixnum) end)) 156 (push (subseq string pos end) output) 157 (setq pos (1+ end)))) 158 159#-allegro 160(eval-when (:compile-toplevel :load-toplevel :execute) 161 (defvar if*-keyword-list '("then" "thenret" "else" "elseif")) 162 163 (defmacro if* (&rest args) 164 (do ((xx (reverse args) (cdr xx)) 165 (state :init) 166 (elseseen nil) 167 (totalcol nil) 168 (lookat nil nil) 169 (col nil)) 170 ((null xx) 171 (cond ((eq state :compl) 172 `(cond ,@totalcol)) 173 (t (error "if*: illegal form ~s" args)))) 174 (cond ((and (symbolp (car xx)) 175 (member (symbol-name (car xx)) 176 if*-keyword-list 177 :test #'string-equal)) 178 (setq lookat (symbol-name (car xx))))) 179 180 (cond ((eq state :init) 181 (cond (lookat (cond ((string-equal lookat "thenret") 182 (setq col nil 183 state :then)) 184 (t (error 185 "if*: bad keyword ~a" lookat)))) 186 (t (setq state :col 187 col nil) 188 (push (car xx) col)))) 189 ((eq state :col) 190 (cond (lookat 191 (cond ((string-equal lookat "else") 192 (cond (elseseen 193 (error 194 "if*: multiples elses"))) 195 (setq elseseen t) 196 (setq state :init) 197 (push `(t ,@col) totalcol)) 198 ((string-equal lookat "then") 199 (setq state :then)) 200 (t (error "if*: bad keyword ~s" 201 lookat)))) 202 (t (push (car xx) col)))) 203 ((eq state :then) 204 (cond (lookat 205 (error 206 "if*: keyword ~s at the wrong place " (car xx))) 207 (t (setq state :compl) 208 (push `(,(car xx) ,@col) totalcol)))) 209 ((eq state :compl) 210 (cond ((not (string-equal lookat "elseif")) 211 (error "if*: missing elseif clause "))) 212 (setq state :init)))))) 213 214 215(defclass uri () 216 ( 217;;;; external: 218 (scheme :initarg :scheme :initform nil :accessor uri-scheme) 219 (host :initarg :host :initform nil :accessor uri-host) 220 (port :initarg :port :initform nil :accessor uri-port) 221 (path :initarg :path :initform nil :accessor uri-path) 222 (query :initarg :query :initform nil :accessor uri-query) 223 (fragment :initarg :fragment :initform nil :accessor uri-fragment) 224 (plist :initarg :plist :initform nil :accessor uri-plist) 225 226;;;; internal: 227 (escaped 228 ;; used to prevent unnessary work, looking for chars to escape and 229 ;; unescape. 230 :initarg :escaped :initform nil :accessor uri-escaped) 231 (string 232 ;; the cached printable representation of the URI. It *might* be 233 ;; different than the original string, though, because the user might 234 ;; have escaped non-reserved chars--they won't be escaped when the URI 235 ;; is printed. 236 :initarg :string :initform nil :accessor uri-string) 237 (parsed-path 238 ;; the cached parsed representation of the URI path. 239 :initarg :parsed-path 240 :initform nil 241 :accessor .uri-parsed-path) 242 (is-ip6 243 :initarg :is-ip6 244 :initform nil 245 :accessor uri-is-ip6) 246 (hashcode 247 ;; cached sxhash, so we don't have to compute it more than once. 248 :initarg :hashcode :initform nil :accessor uri-hashcode))) 249 250(defclass urn (uri) 251 ((nid :initarg :nid :initform nil :accessor urn-nid) 252 (nss :initarg :nss :initform nil :accessor urn-nss))) 253 254(eval-when (:compile-toplevel :execute) 255 (defmacro clear-caching-on-slot-change (name) 256 `(defmethod (setf ,name) :around (new-value (self uri)) 257 (declare (ignore new-value)) 258 (prog1 (call-next-method) 259 (setf (uri-string self) nil) 260 ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil))) 261 (setf (uri-hashcode self) nil)))) 262 ) 263 264(clear-caching-on-slot-change uri-scheme) 265(clear-caching-on-slot-change uri-host) 266(clear-caching-on-slot-change uri-port) 267(clear-caching-on-slot-change uri-path) 268(clear-caching-on-slot-change uri-query) 269(clear-caching-on-slot-change uri-fragment) 270 271 272(defmethod make-load-form ((self uri) &optional env) 273 (declare (ignore env)) 274 `(make-instance ',(class-name (class-of self)) 275 :scheme ,(uri-scheme self) 276 :host ,(uri-host self) 277 :port ,(uri-port self) 278 :path ',(uri-path self) 279 :query ,(uri-query self) 280 :fragment ,(uri-fragment self) 281 :plist ',(uri-plist self) 282 :string ,(uri-string self) 283 :parsed-path ',(.uri-parsed-path self))) 284 285(defmethod uri-p ((thing uri)) t) 286(defmethod uri-p ((thing t)) nil) 287 288(defun copy-uri (uri 289 &key place 290 (scheme (when uri (uri-scheme uri))) 291 (host (when uri (uri-host uri))) 292 (port (when uri (uri-port uri))) 293 (path (when uri (uri-path uri))) 294 (parsed-path 295 (when uri (copy-list (.uri-parsed-path uri)))) 296 (query (when uri (uri-query uri))) 297 (fragment (when uri (uri-fragment uri))) 298 (plist (when uri (copy-list (uri-plist uri)))) 299 (class (when uri (class-of uri))) 300 &aux (escaped (when uri (uri-escaped uri)))) 301 (if* place 302 then (setf (uri-scheme place) scheme) 303 (setf (uri-host place) host) 304 (setf (uri-port place) port) 305 (setf (uri-path place) path) 306 (setf (.uri-parsed-path place) parsed-path) 307 (setf (uri-query place) query) 308 (setf (uri-fragment place) fragment) 309 (setf (uri-plist place) plist) 310 (setf (uri-escaped place) escaped) 311 (setf (uri-string place) nil) 312 (setf (uri-hashcode place) nil) 313 place 314 elseif (eq 'uri class) 315 then ;; allow the compiler to optimize the call to make-instance: 316 (make-instance 'uri 317 :scheme scheme :host host :port port :path path 318 :parsed-path parsed-path 319 :query query :fragment fragment :plist plist 320 :escaped escaped :string nil :hashcode nil) 321 else (make-instance class 322 :scheme scheme :host host :port port :path path 323 :parsed-path parsed-path 324 :query query :fragment fragment :plist plist 325 :escaped escaped :string nil :hashcode nil))) 326 327(defmethod uri-parsed-path ((uri uri)) 328 (when (uri-path uri) 329 (when (null (.uri-parsed-path uri)) 330 (setf (.uri-parsed-path uri) 331 (parse-path (uri-path uri) (uri-escaped uri)))) 332 (.uri-parsed-path uri))) 333 334(defmethod (setf uri-parsed-path) (path-list (uri uri)) 335 (assert (and (consp path-list) 336 (or (member (car path-list) '(:absolute :relative) 337 :test #'eq)))) 338 (setf (uri-path uri) (render-parsed-path path-list t)) 339 (setf (.uri-parsed-path uri) path-list) 340 path-list) 341 342(defun uri-authority (uri) 343 (when (uri-host uri) 344 (let ((*print-pretty* nil)) 345 (format nil "~a~@[:~a~]" (uri-host uri) (uri-port uri))))) 346 347(defun uri-nid (uri) 348 (if* (equalp "urn" (uri-scheme uri)) 349 then (uri-host uri) 350 else (error "URI is not a URN: ~s." uri))) 351 352(defun uri-nss (uri) 353 (if* (equalp "urn" (uri-scheme uri)) 354 then (uri-path uri) 355 else (error "URI is not a URN: ~s." uri))) 356 357;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 358;; Parsing 359 360(defparameter *excluded-characters* 361 (append 362 ;; exclude control characters 363 (loop for i from 0 to #x1f 364 collect (code-char i)) 365 '(;; `delims' (except #\%, because it's handled specially): 366 #\< #\> #\" #\space #\# 367 #\Rubout ;; (code-char #x7f) 368 ;; `unwise': 369 #\{ #\} #\| #\\ #\^ #\[ #\] #\`)) 370 "Excluded charcters from RFC2396 (http://www.ietf.org/rfc/rfc2396.txt 2.4.3)") 371 372(defun reserved-char-vector (chars &key except) 373 (do* ((a (make-array 128 :element-type 'bit :initial-element 0)) 374 (chars chars (cdr chars)) 375 (c (car chars) (car chars))) 376 ((null chars) a) 377 (if* (and except (member c except :test #'char=)) 378 thenret 379 else (setf (sbit a (char-int c)) 1)))) 380 381(defparameter *reserved-characters* 382 (reserved-char-vector 383 (append *excluded-characters* 384 '(#\; #\/ #\? #\: #\@ #\& #\= #\+ #\$ #\, #\%)))) 385(defparameter *reserved-authority-characters* 386 (reserved-char-vector 387 (append *excluded-characters* '(#\; #\/ #\? #\: #\@)))) 388(defparameter *reserved-path-characters* 389 (reserved-char-vector 390 (append *excluded-characters* 391 '(#\; #\% 392;;;;The rfc says this should be here, but it doesn't make sense. 393 ;; #\= 394 #\/ #\?)))) 395 396(defparameter *reserved-fragment-characters* 397 (reserved-char-vector (remove #\# *excluded-characters*))) 398 399(eval-when (:compile-toplevel :execute) 400(defun gen-char-range-list (start end) 401 (do* ((res '()) 402 (endcode (1+ (char-int end))) 403 (chcode (char-int start) 404 (1+ chcode)) 405 (hyphen nil)) 406 ((= chcode endcode) 407 ;; - has to be first, otherwise it signifies a range! 408 (if* hyphen 409 then (setq res (nreverse res)) 410 (push #\- res) 411 res 412 else (nreverse res))) 413 (if* (= #.(char-int #\-) chcode) 414 then (setq hyphen t) 415 else (push (code-char chcode) res)))) 416) 417 418(defparameter *valid-nid-characters* 419 (reserved-char-vector 420 '#.(nconc (gen-char-range-list #\a #\z) 421 (gen-char-range-list #\A #\Z) 422 (gen-char-range-list #\0 #\9) 423 '(#\- #\. #\+)))) 424(defparameter *reserved-nss-characters* 425 (reserved-char-vector 426 (append *excluded-characters* '(#\& #\~ #\/ #\?)))) 427 428(defparameter *illegal-characters* 429 (reserved-char-vector (set-difference *excluded-characters* 430 '(#\# #\[ #\])))) 431(defparameter *strict-illegal-query-characters* 432 (reserved-char-vector (append '(#\?) (remove #\# *excluded-characters*)))) 433(defparameter *illegal-query-characters* 434 (reserved-char-vector 435 *excluded-characters* :except '(#\^ #\| #\#))) 436 437(defparameter *valid-ip6-characters* 438 (reserved-char-vector 439 '#.(nconc (gen-char-range-list #\a #\f) 440 (gen-char-range-list #\A #\F) 441 (gen-char-range-list #\0 #\9) 442 '(#\: #\])))) 443 444 445(defun parse-uri (thing &key (class 'uri) &aux escape) 446 (when (uri-p thing) (return-from parse-uri thing)) 447 448 (setq escape (escape-p thing)) 449 (multiple-value-bind (scheme host port path query fragment is-ip6) 450 (parse-uri-string thing) 451 (when scheme 452 (setq scheme 453 (intern (funcall 454 (case *current-case-mode* 455 ((:case-insensitive-upper :case-sensitive-upper) 456 #'string-upcase) 457 ((:case-insensitive-lower :case-sensitive-lower) 458 #'string-downcase)) 459 (decode-escaped-encoding scheme escape)) 460 (find-package :keyword)))) 461 462 (when (and scheme (eq :urn scheme)) 463 (return-from parse-uri 464 (make-instance 'urn :scheme scheme :nid host :nss path))) 465 466 (when host (setq host (decode-escaped-encoding host escape))) 467 (when port 468 (setq port (read-from-string port)) 469 (when (not (numberp port)) (error "port is not a number: ~s." port)) 470 (when (not (plusp port)) 471 (error "port is not a positive integer: ~d." port)) 472 (when (eql port (case scheme 473 (:http 80) 474 (:https 443) 475 (:ftp 21) 476 (:telnet 23))) 477 (setq port nil))) 478 (when (or (string= "" path) 479 (and ;; we canonicalize away a reference to just /: 480 scheme 481 (member scheme '(:http :https :ftp) :test #'eq) 482 (string= "/" path))) 483 (setq path nil)) 484 (when path 485 (setq path 486 (decode-escaped-encoding path escape *reserved-path-characters*))) 487 (when query (setq query (decode-escaped-encoding query escape))) 488 (when fragment 489 (setq fragment 490 (decode-escaped-encoding fragment escape 491 *reserved-fragment-characters*))) 492 (if* (eq 'uri class) 493 then ;; allow the compiler to optimize the make-instance call: 494 (make-instance 'uri 495 :scheme scheme 496 :host host 497 :is-ip6 is-ip6 498 :port port 499 :path path 500 :query query 501 :fragment fragment 502 :escaped escape) 503 else ;; do it the slow way: 504 (make-instance class 505 :scheme scheme 506 :host host 507 :is-ip6 is-ip6 508 :port port 509 :path path 510 :query query 511 :fragment fragment 512 :escaped escape)))) 513 514(defmethod uri ((thing uri)) 515 thing) 516 517(defmethod uri ((thing string)) 518 (parse-uri thing)) 519 520(defmethod uri ((thing t)) 521 (error "Cannot coerce ~s to a uri." thing)) 522 523(defvar *strict-parse* t) 524 525(defun parse-uri-string (string &aux (illegal-chars *illegal-characters*)) 526 (declare (optimize (speed 3))) 527 ;; Speed is important, so use a specialized state machine instead of 528 ;; regular expressions for parsing the URI string. The regexp we are 529 ;; simulating: 530 ;; ^(([^:/?#]+):)? 531 ;; (//([^/?#]*))? 532 ;; May include a []-pair for ipv6 533 ;; ([^?#]*) 534 ;; (\?([^#]*))? 535 ;; (#(.*))? 536 (let* ((state 0) 537 (start 0) 538 (end (length string)) 539 (tokval nil) 540 (scheme nil) 541 (host nil) 542 (is-ip6 nil) 543 (port nil) 544 (path-components '()) 545 (query nil) 546 (fragment nil) 547 ;; namespace identifier, for urn parsing only: 548 (nid nil)) 549 (declare (fixnum state start end)) 550 (flet ((read-token (kind &optional legal-chars) 551 (setq tokval nil) 552 (if* (>= start end) 553 then :end 554 else (let ((sindex start) 555 (res nil) 556 c) 557 (declare (fixnum sindex)) 558 (setq res 559 (loop 560 (when (>= start end) (return nil)) 561 (setq c (char string start)) 562 (let ((ci (char-int c))) 563 (if* legal-chars 564 then (if* (and (eq :colon kind) (eq c #\:)) 565 then (return :colon) 566 elseif (= 0 (sbit legal-chars ci)) 567 then (.parse-error 568 "~ 569URI ~s contains illegal character ~s at position ~d." 570 string c start)) 571 elseif (and (< ci 128) 572 *strict-parse* 573 (= 1 (sbit illegal-chars ci))) 574 then (.parse-error "~ 575URI ~s contains illegal character ~s at position ~d." 576 string c start))) 577 (case kind 578 (:path (case c 579 (#\? (return :question)) 580 (#\# (return :hash)))) 581 (:query (case c (#\# (return :hash)))) 582 (:ip6 (case c 583 (#\] (return :close-bracket)))) 584 (:rest) 585 (t (case c 586 (#\: (return :colon)) 587 (#\? (return :question)) 588 (#\[ (return :open-bracket)) 589 (#\] (return :close-bracket)) 590 (#\# (return :hash)) 591 (#\/ (return :slash))))) 592 (incf start))) 593 (if* (> start sindex) 594 then ;; we found some chars 595 ;; before we stopped the parse 596 (setq tokval (subseq string sindex start)) 597 :string 598 else ;; immediately stopped at a special char 599 (incf start) 600 res)))) 601 (failure (&optional why) 602 (.parse-error "illegal URI: ~s [~d]~@[: ~a~]" 603 string state why)) 604 (impossible () 605 (.parse-error "impossible state: ~d [~s]" state string))) 606 (loop 607 (case state 608 (0 ;; starting to parse 609 (ecase (read-token t) 610 (:colon (failure)) 611 (:question (setq state 7)) 612 (:hash (setq state 8)) 613 (:slash (setq state 3)) 614 (:string (setq state 1)) 615 (:end (setq state 9)))) 616 (1 ;; seen <token><special char> 617 (let ((token tokval)) 618 (ecase (read-token t) 619 (:colon (setq scheme token) 620 (if* (equalp "urn" scheme) 621 then (setq state 15) 622 else (setq state 2))) 623 (:question (push token path-components) 624 (setq state 7)) 625 (:hash (push token path-components) 626 (setq state 8)) 627 (:slash (push token path-components) 628 (push "/" path-components) 629 (setq state 6)) 630 (:string (failure)) 631 (:end (push token path-components) 632 (setq state 9))))) 633 (2 ;; seen <scheme>: 634 (ecase (read-token t) 635 (:colon (failure)) 636 (:question (setq state 7)) 637 (:hash (setq state 8)) 638 (:slash (setq state 3)) 639 (:string (setq state 10)) 640 (:end (setq state 9)))) 641 (10 ;; seen <scheme>:<token> 642 (let ((token tokval)) 643 (ecase (read-token t) 644 (:colon (failure)) 645 (:question (push token path-components) 646 (setq state 7)) 647 (:hash (push token path-components) 648 (setq state 8)) 649 (:slash (push token path-components) 650 (setq state 6)) 651 (:string (failure)) 652 (:end (push token path-components) 653 (setq state 9))))) 654 (3 ;; seen / or <scheme>:/ 655 (ecase (read-token t) 656 (:colon (failure)) 657 (:question (push "/" path-components) 658 (setq state 7)) 659 (:hash (push "/" path-components) 660 (setq state 8)) 661 (:slash (setq state 4)) 662 (:string (push "/" path-components) 663 (push tokval path-components) 664 (setq state 6)) 665 (:end (push "/" path-components) 666 (setq state 9)))) 667 (66 ;; seen [<scheme>:]//[ 668 (ecase (read-token :ip6 *valid-ip6-characters*) 669 (:string (setq host tokval) 670 (setq is-ip6 t) 671 (setq state 67)))) 672 (67 ;; seen [<scheme>:]//[ip6] 673 (ecase (read-token t) 674 (:close-bracket (setq state 11)))) 675 (4 ;; seen [<scheme>:]// 676 (ecase (read-token t) 677 (:colon (failure)) 678 (:question (failure)) 679 (:hash (failure)) 680 (:open-bracket (setq state 66)) 681 (:slash 682 (if* (and (equalp "file" scheme) 683 (null host)) 684 then ;; file:///... 685 (push "/" path-components) 686 (setq state 6) 687 else (failure))) 688 (:string (setq host tokval) 689 (setq state 11)) 690 (:end (failure)))) 691 (11 ;; seen [<scheme>:]//<host> 692 (ecase (read-token t) 693 (:colon (setq state 5)) 694 (:question (setq state 7)) 695 (:hash (setq state 8)) 696 (:slash (push "/" path-components) 697 (setq state 6)) 698 (:string (impossible)) 699 (:end (setq state 9)))) 700 (5 ;; seen [<scheme>:]//<host>: 701 (ecase (read-token t) 702 (:colon (failure)) 703 (:question (failure)) 704 (:hash (failure)) 705 (:slash (push "/" path-components) 706 (setq state 6)) 707 (:string (setq port tokval) 708 (setq state 12)) 709 (:end (failure)))) 710 (12 ;; seen [<scheme>:]//<host>:[<port>] 711 (ecase (read-token t) 712 (:colon (failure)) 713 (:question (setq state 7)) 714 (:hash (setq state 8)) 715 (:slash (push "/" path-components) 716 (setq state 6)) 717 (:string (impossible)) 718 (:end (setq state 9)))) 719 (6 ;; seen / 720 (ecase (read-token :path) 721 (:question (setq state 7)) 722 (:hash (setq state 8)) 723 (:string (push tokval path-components) 724 (setq state 13)) 725 (:end (setq state 9)))) 726 (13 ;; seen path 727 (ecase (read-token :path) 728 (:question (setq state 7)) 729 (:hash (setq state 8)) 730 (:string (impossible)) 731 (:end (setq state 9)))) 732 (7 ;; seen ? 733 (setq illegal-chars 734 (if* *strict-parse* 735 then *strict-illegal-query-characters* 736 else *illegal-query-characters*)) 737 (ecase (prog1 (read-token :query) 738 (setq illegal-chars *illegal-characters*)) 739 (:hash (setq state 8)) 740 (:string (setq query tokval) 741 (setq state 14)) 742 (:end (setq state 9)))) 743 (14 ;; query 744 (ecase (read-token :query) 745 (:hash (setq state 8)) 746 (:string (impossible)) 747 (:end (setq state 9)))) 748 (8 ;; seen # 749 (ecase (read-token :rest) 750 (:string (setq fragment tokval) 751 (setq state 9)) 752 (:end (setq state 9)))) 753 (9 ;; done 754 (return 755 (values 756 scheme host port 757 (apply #'concatenate 'string (nreverse path-components)) 758 query fragment is-ip6))) 759 ;; URN parsing: 760 (15 ;; seen urn:, read nid now 761 (case (read-token :colon *valid-nid-characters*) 762 (:string (setq nid tokval) 763 (setq state 16)) 764 (t (failure "missing namespace identifier")))) 765 (16 ;; seen urn:<nid> 766 (case (read-token t) 767 (:colon (setq state 17)) 768 (t (failure "missing namespace specific string")))) 769 (17 ;; seen urn:<nid>:, rest is nss 770 (return (values scheme 771 nid 772 nil 773 (progn 774 (setq illegal-chars *reserved-nss-characters*) 775 (read-token :rest) 776 tokval)))) 777 (t (.parse-error 778 "internal error in parse engine, wrong state: ~s." state))))))) 779 780(defun escape-p (string) 781 (declare (optimize (speed 3))) 782 (do* ((i 0 (1+ i)) 783 (max (the fixnum (length string)))) 784 ((= i max) nil) 785 (declare (fixnum i max)) 786 (when (char= #\% (char string i)) 787 (return t)))) 788 789(defun parse-path (path-string escape) 790 (do* ((xpath-list (delimited-string-to-list path-string #\/)) 791 (path-list 792 (progn 793 (if* (string= "" (car xpath-list)) 794 then (setf (car xpath-list) :absolute) 795 else (push :relative xpath-list)) 796 xpath-list)) 797 (pl (cdr path-list) (cdr pl)) 798 segments) 799 ((null pl) path-list) 800 801 (if* (cdr (setq segments 802 (if* (string= "" (car pl)) 803 then '("") 804 else (delimited-string-to-list (car pl) #\;)))) 805 then ;; there is a param 806 (setf (car pl) 807 (mapcar #'(lambda (s) 808 (decode-escaped-encoding s escape 809 ;; decode all %xx: 810 nil)) 811 segments)) 812 else ;; no param 813 (setf (car pl) 814 (decode-escaped-encoding (car segments) escape 815 ;; decode all %xx: 816 nil))))) 817 818(defun decode-escaped-encoding (string escape 819 &optional (reserved-chars 820 *reserved-characters*)) 821 ;; Return a string with the real characters. 822 (when (null escape) (return-from decode-escaped-encoding string)) 823 (do* ((i 0 (1+ i)) 824 (max (length string)) 825 (new-string (copy-seq string)) 826 (new-i 0 (1+ new-i)) 827 ch ch2 chc chc2) 828 ((= i max) 829 (shrink-vector new-string new-i)) 830 (if* (char= #\% (setq ch (char string i))) 831 then (when (> (+ i 3) max) 832 (.parse-error 833 "Unsyntactic escaped encoding in ~s." string)) 834 (setq ch (char string (incf i))) 835 (setq ch2 (char string (incf i))) 836 (when (not (and (setq chc (digit-char-p ch 16)) 837 (setq chc2 (digit-char-p ch2 16)))) 838 (.parse-error 839 "Non-hexidecimal digits after %: %c%c." ch ch2)) 840 (let ((ci (+ (* 16 chc) chc2))) 841 (if* (or (null reserved-chars) 842 (> ci 127) ; bug11527 843 (= 0 (sbit reserved-chars ci))) 844 then ;; ok as is 845 (setf (char new-string new-i) 846 (code-char ci)) 847 else (setf (char new-string new-i) #\%) 848 (setf (char new-string (incf new-i)) ch) 849 (setf (char new-string (incf new-i)) ch2))) 850 else (setf (char new-string new-i) ch)))) 851 852;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 853;;;; Printing 854 855(defun render-uri (uri stream 856 &aux (escape (uri-escaped uri)) 857 (*print-pretty* nil)) 858 (when (null (uri-string uri)) 859 (setf (uri-string uri) 860 (let ((scheme (uri-scheme uri)) 861 (host (uri-host uri)) 862 (is-ip6 (uri-is-ip6 uri)) 863 (port (uri-port uri)) 864 (path (uri-path uri)) 865 (query (uri-query uri)) 866 (fragment (uri-fragment uri))) 867 (concatenate 'string 868 (when scheme 869 (encode-escaped-encoding 870 (string-downcase ;; for upper case lisps 871 (symbol-name scheme)) 872 *reserved-characters* escape)) 873 (when scheme ":") 874 (when (or host (eq :file scheme)) "//") 875 (when is-ip6 "[") 876 (when host 877 (encode-escaped-encoding 878 host *reserved-authority-characters* escape)) 879 (when is-ip6 "]") 880 (when port ":") 881 (when port 882 #-allegro (format nil "~D" port) 883 #+allegro (with-output-to-string (s) 884 (excl::maybe-print-fast s port)) 885 ) 886 (encode-escaped-encoding (or path "/") 887 nil 888 ;;*reserved-path-characters* 889 escape) 890 (when query "?") 891 (when query (encode-escaped-encoding query nil escape)) 892 (when fragment "#") 893 (when fragment (encode-escaped-encoding fragment nil escape)))))) 894 (if* stream 895 then (format stream "~a" (uri-string uri)) 896 else (uri-string uri))) 897 898(defun render-parsed-path (path-list escape) 899 (do* ((res '()) 900 (first (car path-list)) 901 (pl (cdr path-list) (cdr pl)) 902 (pe (car pl) (car pl))) 903 ((null pl) 904 (when res (apply #'concatenate 'string (nreverse res)))) 905 (when (or (null first) 906 (prog1 (eq :absolute first) 907 (setq first nil))) 908 (push "/" res)) 909 (if* (atom pe) 910 then (push 911 (encode-escaped-encoding pe *reserved-path-characters* escape) 912 res) 913 else ;; contains params 914 (push (encode-escaped-encoding 915 (car pe) *reserved-path-characters* escape) 916 res) 917 (dolist (item (cdr pe)) 918 (push ";" res) 919 (push (encode-escaped-encoding 920 item *reserved-path-characters* escape) 921 res))))) 922 923(defun render-urn (urn stream 924 &aux (*print-pretty* nil)) 925 (when (null (uri-string urn)) 926 (setf (uri-string urn) 927 (let ((nid (urn-nid urn)) 928 (nss (urn-nss urn))) 929 (concatenate 'string "urn:" nid ":" nss)))) 930 (if* stream 931 then (format stream "~a" (uri-string urn)) 932 else (uri-string urn))) 933 934(defparameter *escaped-encoding* 935 (vector #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f)) 936 937(defun encode-escaped-encoding (string reserved-chars escape) 938 (when (null escape) (return-from encode-escaped-encoding string)) 939 ;; Make a string as big as it possibly needs to be (3 times the original 940 ;; size), and truncate it at the end. 941 (do* ((max (length string)) 942 (new-max (* 3 max)) ;; worst case new size 943 (new-string (make-string new-max)) 944 (i 0 (1+ i)) 945 (new-i -1) 946 c ci) 947 ((= i max) 948 (shrink-vector new-string (incf new-i))) 949 (setq ci (char-int (setq c (char string i)))) 950 (if* (or (null reserved-chars) 951 (> ci 127) 952 (= 0 (sbit reserved-chars ci))) 953 then ;; ok as is 954 (incf new-i) 955 (setf (char new-string new-i) c) 956 else ;; need to escape it 957 (multiple-value-bind (q r) (truncate ci 16) 958 (setf (char new-string (incf new-i)) #\%) 959 (setf (char new-string (incf new-i)) (elt *escaped-encoding* q)) 960 (setf (char new-string (incf new-i)) 961 (elt *escaped-encoding* r)))))) 962 963(defmethod print-object ((uri uri) stream) 964 (if* *print-escape* 965 then (print-unreadable-object (uri stream :type t) (render-uri uri stream)) 966 else (render-uri uri stream))) 967 968(defmethod print-object ((urn urn) stream) 969 (if* *print-escape* 970 then (print-unreadable-object (urn stream :type t) (render-urn urn stream)) 971 else (render-urn urn stream))) 972 973;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 974;; merging and unmerging 975 976(defmethod merge-uris ((uri string) (base string) &optional place) 977 (merge-uris (parse-uri uri) (parse-uri base) place)) 978 979(defmethod merge-uris ((uri uri) (base string) &optional place) 980 (merge-uris uri (parse-uri base) place)) 981 982(defmethod merge-uris ((uri string) (base uri) &optional place) 983 (merge-uris (parse-uri uri) base place)) 984 985 986(defmethod merge-uris ((uri uri) (base uri) &optional place) 987 ;; See ../doc/rfc2396.txt for info on the algorithm we use to merge 988 ;; URIs. 989 ;; 990 (tagbody 991;;;; step 2 992 (when (and (null (uri-parsed-path uri)) 993 (null (uri-scheme uri)) 994 (null (uri-host uri)) 995 (null (uri-port uri)) 996 (null (uri-query uri))) 997 (return-from merge-uris 998 (let ((new (copy-uri base :place place))) 999 (when (uri-query uri) 1000 (setf (uri-query new) (uri-query uri))) 1001 (when (uri-fragment uri) 1002 (setf (uri-fragment new) (uri-fragment uri))) 1003 new))) 1004 1005 (setq uri (copy-uri uri :place place)) 1006 1007;;;; step 3 1008 (when (uri-scheme uri) 1009 (return-from merge-uris uri)) 1010 (setf (uri-scheme uri) (uri-scheme base)) 1011 1012;;;; step 4 1013 (when (uri-host uri) (go :done)) 1014 (setf (uri-host uri) (uri-host base)) 1015 (setf (uri-port uri) (uri-port base)) 1016 1017;;;; step 5 1018 (let ((p (uri-parsed-path uri))) 1019 1020 ;; bug13133: 1021 ;; The following form causes our implementation to be at odds with 1022 ;; RFC 2396, however this is apparently what was intended by the 1023 ;; authors of the RFC. Specifically, (merge-uris "?y" "/foo") 1024 ;; should return #<uri /foo?y> instead of #<uri ?y>, according to 1025 ;; this: 1026;;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query 1027 (when (null p) 1028 (setf (uri-path uri) (uri-path base)) 1029 (go :done)) 1030 1031 (when (and p (eq :absolute (car p))) 1032 (when (equal '(:absolute "") p) 1033 ;; Canonicalize the way parsing does: 1034 (setf (uri-path uri) nil)) 1035 (go :done))) 1036 1037;;;; step 6 1038 (let* ((base-path 1039 (or (uri-parsed-path base) 1040 ;; needed because we canonicalize away a path of just `/': 1041 '(:absolute ""))) 1042 (path (uri-parsed-path uri)) 1043 new-path-list) 1044 (when (not (eq :absolute (car base-path))) 1045 (error "Cannot merge ~a and ~a, since latter is not absolute." 1046 uri base)) 1047 1048 ;; steps 6a and 6b: 1049 (setq new-path-list 1050 (append (butlast base-path) 1051 (if* path then (cdr path) else '("")))) 1052 1053 ;; steps 6c and 6d: 1054 (let ((last (last new-path-list))) 1055 (if* (atom (car last)) 1056 then (when (string= "." (car last)) 1057 (setf (car last) "")) 1058 else (when (string= "." (caar last)) 1059 (setf (caar last) "")))) 1060 (setq new-path-list 1061 (delete "." new-path-list :test #'(lambda (a b) 1062 (if* (atom b) 1063 then (string= a b) 1064 else nil)))) 1065 1066 ;; steps 6e and 6f: 1067 (let ((npl (cdr new-path-list)) 1068 index tmp fix-tail) 1069 (setq fix-tail 1070 (string= ".." (let ((l (car (last npl)))) 1071 (if* (atom l) 1072 then l 1073 else (car l))))) 1074 (loop 1075 (setq index 1076 (position ".." npl 1077 :test #'(lambda (a b) 1078 (string= a 1079 (if* (atom b) 1080 then b 1081 else (car b)))))) 1082 (when (null index) (return)) 1083 (when (= 0 index) 1084 ;; The RFC says, in 6g, "that the implementation may handle 1085 ;; this error by retaining these components in the resolved 1086 ;; path, by removing them from the resolved path, or by 1087 ;; avoiding traversal of the reference." The examples in C.2 1088 ;; imply that we should do the first thing (retain them), so 1089 ;; that's what we'll do. 1090 (return)) 1091 (if* (= 1 index) 1092 then (setq npl (cddr npl)) 1093 else (setq tmp npl) 1094 (dotimes (x (- index 2)) (setq tmp (cdr tmp))) 1095 (setf (cdr tmp) (cdddr tmp)))) 1096 (setf (cdr new-path-list) npl) 1097 (when fix-tail (setq new-path-list (nconc new-path-list '(""))))) 1098 1099 ;; step 6g: 1100 ;; don't complain if new-path-list starts with `..'. See comment 1101 ;; above about this step. 1102 1103 ;; step 6h: 1104 (when (or (equal '(:absolute "") new-path-list) 1105 (equal '(:absolute) new-path-list)) 1106 (setq new-path-list nil)) 1107 (setf (uri-path uri) 1108 (render-parsed-path new-path-list 1109 ;; don't know, so have to assume: 1110 t))) 1111 1112;;;; step 7 1113 :done 1114 (return-from merge-uris uri))) 1115 1116(defmethod enough-uri ((uri string) (base string) &optional place) 1117 (enough-uri (parse-uri uri) (parse-uri base) place)) 1118 1119(defmethod enough-uri ((uri uri) (base string) &optional place) 1120 (enough-uri uri (parse-uri base) place)) 1121 1122(defmethod enough-uri ((uri string) (base uri) &optional place) 1123 (enough-uri (parse-uri uri) base place)) 1124 1125(defmethod enough-uri ((uri uri) (base uri) &optional place) 1126 (let ((new-scheme nil) 1127 (new-host nil) 1128 (new-port nil) 1129 (new-parsed-path nil)) 1130 1131 (when (or (and (uri-scheme uri) 1132 (not (equalp (uri-scheme uri) (uri-scheme base)))) 1133 (and (uri-host uri) 1134 (not (equalp (uri-host uri) (uri-host base)))) 1135 (not (equalp (uri-port uri) (uri-port base)))) 1136 (return-from enough-uri uri)) 1137 1138 (when (null (uri-host uri)) 1139 (setq new-host (uri-host base))) 1140 (when (null (uri-port uri)) 1141 (setq new-port (uri-port base))) 1142 1143 (when (null (uri-scheme uri)) 1144 (setq new-scheme (uri-scheme base))) 1145 1146 ;; Now, for the hard one, path. 1147 ;; We essentially do here what enough-namestring does. 1148 (do* ((base-path (uri-parsed-path base)) 1149 (path (uri-parsed-path uri)) 1150 (bp base-path (cdr bp)) 1151 (p path (cdr p))) 1152 ((or (null bp) (null p)) 1153 ;; If p is nil, that means we have something like 1154 ;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so 1155 ;; new-parsed-path will be nil. 1156 (when (null bp) 1157 (setq new-parsed-path (copy-list p)) 1158 (when (not (symbolp (car new-parsed-path))) 1159 (push :relative new-parsed-path)))) 1160 (if* (equal (car bp) (car p)) 1161 thenret ;; skip it 1162 else (setq new-parsed-path (copy-list p)) 1163 (when (not (symbolp (car new-parsed-path))) 1164 (push :relative new-parsed-path)) 1165 (return))) 1166 1167 (let ((new-path 1168 (when new-parsed-path 1169 (render-parsed-path new-parsed-path 1170 ;; don't know, so have to assume: 1171 t))) 1172 (new-query (uri-query uri)) 1173 (new-fragment (uri-fragment uri)) 1174 (new-plist (copy-list (uri-plist uri)))) 1175 (if* (and (null new-scheme) 1176 (null new-host) 1177 (null new-port) 1178 (null new-path) 1179 (null new-parsed-path) 1180 (null new-query) 1181 (null new-fragment)) 1182 then ;; can't have a completely empty uri! 1183 (copy-uri nil 1184 :class (class-of uri) 1185 :place place 1186 :path "/" 1187 :plist new-plist) 1188 else (copy-uri nil 1189 :class (class-of uri) 1190 :place place 1191 :scheme new-scheme 1192 :host new-host 1193 :port new-port 1194 :path new-path 1195 :parsed-path new-parsed-path 1196 :query new-query 1197 :fragment new-fragment 1198 :plist new-plist))))) 1199 1200;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1201;; support for interning URIs 1202 1203(defun make-uri-space (&rest keys &key (size 777) &allow-other-keys) 1204 #+allegro 1205 (apply #'make-hash-table :size size 1206 :hash-function 'uri-hash 1207 :test 'uri= :values nil keys) 1208 #-allegro 1209 (apply #'make-hash-table :size size keys)) 1210 1211(defun gethash-uri (uri table) 1212 #+allegro (gethash uri table) 1213 #-allegro 1214 (let* ((hash (uri-hash uri)) 1215 (existing (gethash hash table))) 1216 (dolist (u existing) 1217 (when (uri= u uri) 1218 (return-from gethash-uri (values u t)))) 1219 (values nil nil))) 1220 1221(defun puthash-uri (uri table) 1222 #+allegro (excl:puthash-key uri table) 1223 #-allegro 1224 (let ((existing (gethash (uri-hash uri) table))) 1225 (dolist (u existing) 1226 (when (uri= u uri) 1227 (return-from puthash-uri u))) 1228 (setf (gethash (uri-hash uri) table) 1229 (cons uri existing)) 1230 uri)) 1231 1232 1233(defun uri-hash (uri) 1234 (if* (uri-hashcode uri) 1235 thenret 1236 else (setf (uri-hashcode uri) 1237 (sxhash 1238 #+allegro 1239 (render-uri uri nil) 1240 #-allegro 1241 (string-downcase 1242 (render-uri uri nil)))))) 1243 1244(defvar *uris* (make-uri-space)) 1245 1246(defun uri-space () *uris*) 1247 1248(defun (setf uri-space) (new-val) 1249 (setq *uris* new-val)) 1250 1251;; bootstrapping (uri= changed from function to method): 1252(when (fboundp 'uri=) (fmakunbound 'uri=)) 1253 1254(defgeneric uri= (uri1 uri2)) 1255(defmethod uri= ((uri1 uri) (uri2 uri)) 1256 (when (not (eq (uri-scheme uri1) (uri-scheme uri2))) 1257 (return-from uri= nil)) 1258 ;; RFC2396 says: a URL with an explicit ":port", where the port is 1259 ;; the default for the scheme, is the equivalent to one where the 1260 ;; port is elided. Hmmmm. This means that this function has to be 1261 ;; scheme dependent. Grrrr. 1262 (let ((default-port (case (uri-scheme uri1) 1263 (:http 80) 1264 (:https 443) 1265 (:ftp 21) 1266 (:telnet 23)))) 1267 (and (equalp (uri-host uri1) (uri-host uri2)) 1268 (eql (or (uri-port uri1) default-port) 1269 (or (uri-port uri2) default-port)) 1270 (string= (uri-path uri1) (uri-path uri2)) 1271 (string= (uri-query uri1) (uri-query uri2)) 1272 (string= (uri-fragment uri1) (uri-fragment uri2))))) 1273 1274(defmethod uri= ((urn1 urn) (urn2 urn)) 1275 (when (not (eq (uri-scheme urn1) (uri-scheme urn2))) 1276 (return-from uri= nil)) 1277 (and (equalp (urn-nid urn1) (urn-nid urn2)) 1278 (urn-nss-equal (urn-nss urn1) (urn-nss urn2)))) 1279 1280(defun urn-nss-equal (nss1 nss2 &aux len) 1281 ;; Return t iff the nss values are the same. 1282 ;; %2c and %2C are equivalent. 1283 (when (or (null nss1) (null nss2) 1284 (not (= (setq len (length nss1)) 1285 (length nss2)))) 1286 (return-from urn-nss-equal nil)) 1287 (do* ((i 0 (1+ i)) 1288 (state :char) 1289 c1 c2) 1290 ((= i len) t) 1291 (setq c1 (char nss1 i)) 1292 (setq c2 (char nss2 i)) 1293 (ecase state 1294 (:char 1295 (if* (and (char= #\% c1) (char= #\% c2)) 1296 then (setq state :percent+1) 1297 elseif (char/= c1 c2) 1298 then (return nil))) 1299 (:percent+1 1300 (when (char-not-equal c1 c2) (return nil)) 1301 (setq state :percent+2)) 1302 (:percent+2 1303 (when (char-not-equal c1 c2) (return nil)) 1304 (setq state :char))))) 1305 1306(defmethod intern-uri ((xuri uri) &optional (uri-space *uris*)) 1307 (let ((uri (gethash-uri xuri uri-space))) 1308 (if* uri 1309 thenret 1310 else (puthash-uri xuri uri-space)))) 1311 1312(defmethod intern-uri ((uri string) &optional (uri-space *uris*)) 1313 (intern-uri (parse-uri uri) uri-space)) 1314 1315(defun unintern-uri (uri &optional (uri-space *uris*)) 1316 (if* (eq t uri) 1317 then (clrhash uri-space) 1318 elseif (uri-p uri) 1319 then (remhash uri uri-space) 1320 else (error "bad uri: ~s." uri))) 1321 1322(defmacro do-all-uris ((var &optional uri-space result-form) 1323 &rest forms 1324 &environment env) 1325 "do-all-uris (var [[uri-space] result-form]) 1326 {declaration}* {tag | statement}* 1327Executes the forms once for each uri with var bound to the current uri" 1328 (let ((f (gensym)) 1329 (g-ignore (gensym)) 1330 (g-uri-space (gensym)) 1331 (body (third (parse-body forms env)))) 1332 `(let ((,g-uri-space (or ,uri-space *uris*))) 1333 (prog nil 1334 (flet ((,f (,var &optional ,g-ignore) 1335 (declare (ignore-if-unused ,var ,g-ignore)) 1336 (tagbody ,@body))) 1337 (maphash #',f ,g-uri-space)) 1338 (return ,result-form))))) 1339 1340(defun sharp-u (stream chr arg) 1341 (declare (ignore chr arg)) 1342 (let ((arg (read stream nil nil t))) 1343 (if *read-suppress* 1344 nil 1345 (if* (stringp arg) 1346 then (parse-uri arg) 1347 else 1348 1349 (internal-reader-error 1350 stream 1351 "#u takes a string or list argument: ~s" arg))))) 1352 1353 1354(set-dispatch-macro-character #\# #\u #'puri::sharp-u) 1355 1356;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1357 1358(provide :uri) 1359 1360;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1361;; timings 1362;; (don't run under emacs with M-x fi:common-lisp) 1363 1364#+allegro 1365(eval-when (:compile-toplevel :load-toplevel :execute) 1366 (import 'excl::gc)) 1367 1368#-allegro 1369(defun gc (&rest options) 1370 (declare (ignore options)) 1371 #+sbcl (sb-ext::gc) 1372 #+cmu (ext::gc) 1373 ) 1374 1375(defun time-uri-module () 1376 (declare (optimize (speed 3) (safety 0) (debug 0))) 1377 (let ((uri "http://www.franz.com/a/b;x;y;z/c/foo?bar=baz&xxx#foo") 1378 (uri2 "http://www.franz.com/a/b;x;y;z/c/%2ffoo?bar=baz&xxx#foo")) 1379 (gc t) (gc :tenure) (gc :tenure) (gc :tenure) 1380 (format t "~&;;; starting timing testing 1...~%") 1381 (time (dotimes (i 100000) (parse-uri uri))) 1382 1383 (gc t) (gc :tenure) (gc :tenure) (gc :tenure) 1384 (format t "~&;;; starting timing testing 2...~%") 1385 (let ((uri (parse-uri uri))) 1386 (time (dotimes (i 100000) 1387 ;; forces no caching of the printed representation: 1388 (setf (uri-string uri) nil) 1389 (format nil "~a" uri)))) 1390 1391 (gc t) (gc :tenure) (gc :tenure) (gc :tenure) 1392 (format t "~&;;; starting timing testing 3...~%") 1393 (time 1394 (progn 1395 (dotimes (i 100000) (parse-uri uri2)) 1396 (let ((uri (parse-uri uri))) 1397 (dotimes (i 100000) 1398 ;; forces no caching of the printed representation: 1399 (setf (uri-string uri) nil) 1400 (format nil "~a" uri))))))) 1401 1402;;******** reference output (ultra, modified 5.0.1): 1403;;; starting timing testing 1... 1404; cpu time (non-gc) 13,710 msec user, 0 msec system 1405; cpu time (gc) 600 msec user, 10 msec system 1406; cpu time (total) 14,310 msec user, 10 msec system 1407; real time 14,465 msec 1408; space allocation: 1409; 1,804,261 cons cells, 7 symbols, 41,628,832 other bytes, 0 static bytes 1410;;; starting timing testing 2... 1411; cpu time (non-gc) 27,500 msec user, 0 msec system 1412; cpu time (gc) 280 msec user, 20 msec system 1413; cpu time (total) 27,780 msec user, 20 msec system 1414; real time 27,897 msec 1415; space allocation: 1416; 1,900,463 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes 1417;;; starting timing testing 3... 1418; cpu time (non-gc) 52,290 msec user, 10 msec system 1419; cpu time (gc) 1,290 msec user, 30 msec system 1420; cpu time (total) 53,580 msec user, 40 msec system 1421; real time 54,062 msec 1422; space allocation: 1423; 7,800,205 cons cells, 0 symbols, 81,697,496 other bytes, 0 static bytes 1424 1425;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1426;;; after improving decode-escaped-encoding/encode-escaped-encoding: 1427 1428;;; starting timing testing 1... 1429; cpu time (non-gc) 14,520 msec user, 0 msec system 1430; cpu time (gc) 400 msec user, 0 msec system 1431; cpu time (total) 14,920 msec user, 0 msec system 1432; real time 15,082 msec 1433; space allocation: 1434; 1,800,270 cons cells, 0 symbols, 41,600,160 other bytes, 0 static bytes 1435;;; starting timing testing 2... 1436; cpu time (non-gc) 27,490 msec user, 10 msec system 1437; cpu time (gc) 300 msec user, 0 msec system 1438; cpu time (total) 27,790 msec user, 10 msec system 1439; real time 28,025 msec 1440; space allocation: 1441; 1,900,436 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes 1442;;; starting timing testing 3... 1443; cpu time (non-gc) 47,900 msec user, 20 msec system 1444; cpu time (gc) 920 msec user, 10 msec system 1445; cpu time (total) 48,820 msec user, 30 msec system 1446; real time 49,188 msec 1447; space allocation: 1448; 3,700,215 cons cells, 0 symbols, 81,707,144 other bytes, 0 static bytes 1449