Changeset 11801 in project


Ignore:
Timestamp:
08/29/08 22:57:28 (13 years ago)
Author:
sjamaan
Message:

Initial simplifications of uri-generic by using functional update from defstruct.. a few things can still be simplified further

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-generic/trunk/uri-generic.scm

    r11794 r11801  
    733733(define (uri-relative-to ref base)
    734734  (and (uri? ref) (uri? base)
    735        (cond ((uri-scheme ref)      (just-segments ref))
    736              ((uri-authority ref)   (let ((x (just-segments ref)))
    737                                       (URI-scheme-set! x (uri-scheme base))
    738                                       x))
    739 
     735       (cond ((uri-scheme ref)      (update-URI ref
     736                                                path: (just-segments ref)))
     737             ((uri-authority ref)   (update-URI ref
     738                                                path: (just-segments ref)
     739                                                scheme: (uri-scheme base)))
    740740             (((lambda (p) (and (not (null? p)) p))  (uri-path ref)) =>
    741741              (lambda (ref-path)
    742742                (if (and (pair? ref-path) (string-prefix? "/" (car ref-path)))
    743                     (let ((x (just-segments ref)))
    744                       (URI-scheme-set! x (uri-scheme base))
    745                       (URI-authority-set! x (uri-auth base))
    746                       x)
    747                     (let ((x (udup ref)))
    748                       (URI-scheme-set! x (uri-scheme base))
    749                       (URI-authority-set! x (uri-auth base))
    750                       (URI-path-set! x (merge-paths base x))
    751                       (just-segments x)))))
    752 
    753              ((uri-query ref)       (let ((x (udup ref)))
    754                                       (URI-scheme-set! x (uri-scheme base))
    755                                       (URI-authority-set! x (uri-auth base))
    756                                       (URI-path-set! x (list "/"))
    757                                       (URI-path-set! x (merge-paths base x))
    758                                       (just-segments x)))
    759 
    760              (else                  (let ((x (just-segments ref)))
    761                                       (URI-scheme-set! x (uri-scheme base))
    762                                       (URI-authority-set! x (uri-auth base))
    763                                       (URI-path-set! x (uri-path base))
    764                                       (URI-query-set! x (uri-query base))
    765                                       x)))))
     743                    (update-URI ref
     744                                scheme: (uri-scheme base)
     745                                authority: (uri-auth base)
     746                                path: (just-segments ref))
     747                    ;; This one should be simpler
     748                    (let ((x (update-URI ref
     749                                         scheme: (uri-scheme base)
     750                                         authority: (uri-auth base)
     751                                         path: (merge-paths base ref))))
     752                      (URI-path-set! x (just-segments x))
     753                      x))))
     754             ;; This one should be simpler, too
     755             ((uri-query ref) (let ((x (update-URI ref
     756                                                   scheme: (uri-scheme base)
     757                                                   authority: (uri-auth base)
     758                                                   path: (list "/"))))
     759                                (URI-path-set! x (merge-paths base x))
     760                                (URI-path-set! x (just-segments x))
     761                                x))
     762             (else (update-URI ref
     763                               path: (URI-path base)
     764                               scheme: (URI-scheme base)
     765                               authority: (URI-authority base)
     766                               query: (URI-query base))))))
    766767
    767768(define (just-segments u)
    768   (let ((p (remove-dot-segments (uri-path u))))
    769     (update-URI u path: p)))
     769  (remove-dot-segments (uri-path u)))
    770770
    771771(define (merge0 pb pr)
     
    830830
    831831(define (uri-relative-from uabs base)
    832   (cond ((ucdiff? uri-scheme uabs base)      (udup uabs))
    833         ((ucdiff? uri-authority uabs base)   (let ((x (udup uabs)))
    834                                                (URI-scheme-set! x #f)
    835                                                x))
    836         ((ucdiff? uri-path uabs base)       
    837          (let ((x    (udup uabs))
    838                (path (rel-path-from (remove-body-dot-segments (uri-path uabs))
    839                                     (remove-body-dot-segments (uri-path base)))))
    840            (URI-scheme-set! x #f)
    841            (URI-authority-set! x #f)
    842            (URI-path-set! x path)
    843            x))
    844         ((ucdiff? uri-query uabs base)
    845          (let ((x (udup uabs)))
    846            (URI-scheme-set! x #f)
    847            (URI-authority-set! x #f)
    848            (URI-path-set! x (list))
    849            x))
    850         (else                             
    851          (let ((x (udup uabs)))
    852            (URI-scheme-set! x #f)
    853            (URI-authority-set! x #f)
    854            (URI-query-set! x #f)
    855            (URI-path-set! x (list))
    856            x))))
    857 
    858 
    859 (define (udup u)
    860   (update-URI u))
     832  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
     833        ((ucdiff? uri-authority uabs base)   (update-URI uabs scheme: #f))
     834        ((ucdiff? uri-path uabs base)
     835         (update-URI uabs
     836                     scheme: #f
     837                     authority: #f
     838                     path: (rel-path-from
     839                            (remove-body-dot-segments (uri-path uabs))
     840                            (remove-body-dot-segments (uri-path base)))))
     841        ((ucdiff? uri-query uabs base)
     842         (update-URI uabs
     843                     scheme: #f
     844                     authority: #f
     845                     path: (list)))
     846        (else (update-URI uabs
     847                          scheme: #f
     848                          authority: #f
     849                          query: #f
     850                          path: (list)))))
    861851
    862852(define (ucdiff? sel u1 u2)
     
    937927
    938928
    939 
    940929;; Other normalization functions
    941930;;
     
    944933
    945934(define (uri-normalize-case uri)
    946   (let ((u1      (udup uri))
    947         (scheme  (string->symbol (string-downcase (->string (uri-scheme uri)))))
     935  (let ((scheme  (string->symbol (string-downcase (->string (uri-scheme uri)))))
    948936        (path    (map (lambda (c) (match c (('% h1 h2)  `(% ,(char-upcase h1) ,(char-upcase h2)))
    949937                                         (else c))) (uri-path uri))))
    950     (URI-scheme-set! u1 scheme)
    951     (URI-path-set! u1 path)
    952     u1))
     938    (update-URI uri scheme: scheme path: path)))
    953939
    954940
     
    956942
    957943(define (uri-normalize-path-segments uri)
    958   (let ((u1      (udup uri))
    959         (path    (remove-dot-segments (uri-path uri))))
    960     (URI-path-set! u1 path)
    961     u1))
     944  (update-URI uri path: (just-segments uri)))
    962945)
Note: See TracChangeset for help on using the changeset viewer.