changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/obj/uri/print.lisp

changeset 698: 96958d3eb5b0
parent: 8d7aa0af2367
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; obj/uri/print.lisp --- URI printers
     2 
     3 ;;
     4 
     5 ;;; Code:
     6 (in-package :obj/uri)
     7 (defvar *render-include-slash-on-null-path* nil) ;; rfe11850
     8 (defvar *uri-schema-print-case* :downcase)
     9 
    10 (defmethod render-uri ((uri uri) stream
    11                        &aux (encode (uri-escaped uri))
    12                             (*print-pretty* nil)
    13                             res)
    14   (declare (optimize (safety 0)))
    15   (when (null (setq res (uri-string uri)))
    16     (setf (uri-string uri)
    17       (let ((scheme (uri-scheme uri))
    18             (host (%uri-host uri))
    19             (ipv6 (%uri-ipv6 uri))
    20             zone-id ;; don't compute until needed
    21             (userinfo (uri-userinfo uri))
    22             (port (uri-port uri))
    23             (path (uri-path uri))
    24             (query (uri-query uri))
    25             (fragment (uri-fragment uri)))
    26         (setq res
    27           (concatenate 'string
    28            (when scheme
    29              (case *uri-schema-print-case*
    30                ((:downcase)
    31                 (string-downcase (symbol-name scheme)))
    32                ((:upcase)
    33                 (symbol-name scheme))))
    34            (when scheme ":")
    35            (when (or host ipv6 (eq :file scheme) (eq :hdfs scheme))
    36              "//")
    37            (when userinfo
    38              (if* encode
    39                 then (percent-encode-string userinfo *userinfo-bitvector*)
    40                 else userinfo))
    41            (when userinfo "@")
    42            (if* ipv6
    43               then (if* (setq zone-id (%uri-zone-id uri))
    44                       then (concatenate 'string "[" ipv6 "%25" zone-id "]")
    45                       else (concatenate 'string "[" ipv6 "]"))
    46             elseif host
    47               then (if* encode
    48                       then (percent-encode-string host *reg-name-bitvector*)
    49                       else host))
    50            (when port (format nil ":~d" port))
    51            (if* path
    52               then path
    53             elseif (and *render-include-slash-on-null-path*
    54                         #|no path but:|# scheme host)
    55               then "/")
    56            (when query "?")
    57            (when query
    58              (if* encode
    59                 then (percent-encode-string
    60                       query
    61                       (if* *strict-parse*
    62                          then *query-bitvector-strict*
    63                          else *query-bitvector-non-strict*))
    64                 else query))
    65            (when fragment "#")
    66            (when fragment
    67              (if* encode
    68                 then (percent-encode-string
    69                       fragment
    70                       (if* *strict-parse*
    71                          then *fragment-bitvector-strict*
    72                          else *fragment-bitvector-non-strict*))
    73                 else fragment))))))
    74 
    75     ;; calculate this cached slot
    76     (uri-parsed-path uri))
    77 
    78   (if* stream
    79      then (princ res stream)
    80      else res))
    81 
    82 (defmethod render-uri ((urn urn) stream
    83                        &aux (*print-pretty* nil))
    84   ;; This doesn't do encoding because no decoding is done for URNs when
    85   ;; they are parsed.
    86   (when (null (uri-string urn))
    87     (setf (uri-string urn)
    88       (let ((nid (urn-nid urn))
    89             (nss (urn-nss urn))
    90             (r (urn-r-component urn))
    91             (q (urn-q-component urn))
    92             (f (urn-f-component urn)))
    93         (concatenate 'string "urn:" nid ":" nss
    94                      (when r "?+")
    95                  (when r r)
    96                  (when q "?=")
    97                  (when q q)
    98                  (when f "#")
    99                  (when f f)))))
   100   (if* stream
   101      then (write-string (uri-string urn) stream)
   102      else (uri-string urn)))
   103 
   104 (defmethod uri-to-string ((uri uri)
   105                           &aux (encode (uri-escaped uri))
   106                                (*print-pretty* nil)
   107                                res)
   108   (declare (optimize (safety 0)))
   109   (when (null (setq res (uri-string uri)))
   110     (setf (uri-string uri)
   111       (let ((scheme (uri-scheme uri))
   112             (host (%uri-host uri))
   113             (ipv6 (%uri-ipv6 uri))
   114             zone-id ;; don't compute until needed
   115             (userinfo (uri-userinfo uri))
   116             (port (uri-port uri))
   117             (path (uri-path uri))
   118             (query (uri-query uri))
   119             (fragment (uri-fragment uri)))
   120         (setq res
   121           (concatenate 'string
   122            (when scheme
   123              (case *uri-schema-print-case*
   124                ((:downcase)
   125                 (string-downcase (symbol-name scheme)))
   126                ((:upcase)
   127                 (symbol-name scheme))))
   128            (when scheme ":")
   129            (when (or host ipv6 (eq :file scheme) (eq :hdfs scheme))
   130              "//")
   131            (when userinfo
   132              (if* encode
   133                 then (percent-encode-string userinfo *userinfo-bitvector*)
   134                 else userinfo))
   135            (when userinfo "@")
   136            (if* ipv6
   137               then (if* (setq zone-id (%uri-zone-id uri))
   138                       then (concatenate 'string "[" ipv6 "%25" zone-id "]")
   139                       else (concatenate 'string "[" ipv6 "]"))
   140             elseif host
   141               then (if* encode
   142                       then (percent-encode-string host *reg-name-bitvector*)
   143                       else host))
   144            (when port ":")
   145            (when port port)
   146            (if* path
   147               then path
   148             elseif (and *render-include-slash-on-null-path*
   149                         #|no path but:|# scheme host)
   150               then "/")
   151            (when query "?")
   152            query
   153            (when fragment "#")
   154            (when fragment
   155              (if* encode
   156                 then (percent-encode-string
   157                       fragment
   158                       (if* *strict-parse*
   159                          then *fragment-bitvector-strict*
   160                          else *fragment-bitvector-non-strict*))
   161                 else fragment))))))
   162 
   163     ;; calculate this cached slot
   164     (uri-parsed-path uri))
   165 
   166   res)
   167 
   168 (defmethod iri-to-string ((iri iri))
   169   (uri-to-string iri))
   170 
   171 (defmethod uri-to-string ((urn urn))
   172   ;; We can use render-uri here because no decoding/encoding happens for
   173   ;; URNs.
   174   (render-uri urn nil))
   175 
   176 (defun render-parsed-path (path-list escape)
   177   (do* ((res '())
   178         (first (car path-list))
   179         (pl (cdr path-list) (cdr pl))
   180         (pe (car pl) (car pl)))
   181       ((null pl)
   182        (when res (apply #'concatenate 'string (nreverse res))))
   183     (when (or (null first)
   184               (prog1 (and (eq :absolute first)
   185                           ;; Only happens on Windows, in the case of a path
   186                           ;; with a drive letter in it.  The drive letter
   187                           ;; element is a keyword naming the drive.
   188                           (not (keywordp pe)))
   189                 (setq first nil)))
   190       (push "/" res))
   191     (if* (symbolp pe)
   192        then ;; Only happens on Windows.  It's a keyword corresponding to
   193             ;; the drive letter.
   194             (push (format nil "~a:" pe) res)
   195      elseif (atom pe)
   196        then (if* escape
   197                then (push (percent-encode-string pe *pchar-bitvector*)
   198                           res)
   199                else (push pe res))
   200        else ;; contains params
   201             (if* escape
   202                then (push (percent-encode-string (car pe) *pchar-bitvector*)
   203                           res)
   204                else (push (car pe) res))
   205             (dolist (item (cdr pe))
   206               (push ";" res)
   207               (if* escape
   208                  then (push (percent-encode-string item *pchar-bitvector*)
   209                             res)
   210                  else (push item res))))))
   211 
   212 (defmethod print-object ((uri uri) stream)
   213   (if* *print-escape*
   214      then (format stream "#<~a ~a>"
   215                   (class-name (class-of uri))
   216                   (render-uri uri nil))
   217      else (render-uri uri stream)))