From 28c891215a6e24eba3a94700554da0dd9c2d79b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 19 Apr 2023 22:05:42 +0200 Subject: Add href-relative. --- module/calp/webdav/resource/base.scm | 9 +++++++++ 1 file changed, 9 insertions(+) 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-children self)) -- cgit v1.2.3