diff options
| -rw-r--r-- | module/calp/webdav/resource/base.scm | 9 |
1 files changed, 9 insertions, 0 deletions
diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm index 95e9ad43..500aef90 100644 --- a/module/calp/webdav/resource/base.scm +++ b/module/calp/webdav/resource/base.scm @@ -17,6 +17,7 @@ ;; href href->string string->href + href-relative ;; local-path name dead-properties @@ -150,6 +151,14 @@ (remove string-null? (string-split s #\/))) +;; parent must be the head of child, elements in child after that is "free range" +(define (href-relative parent child) + (cond ((null? parent) child) + ((null? child) (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)) + ((equal? (car parent) (car child)) + (href-relative (cdr parent) (cdr child))) + (else (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)))) + (define-method (children (self <resource>)) (resource-children self)) |