src.lisp

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