From c429383aa8542104b5ab642bcda64078257e0024 Mon Sep 17 00:00:00 2001 From: MORIOKA Tomohiko Date: Sun, 7 Apr 2019 20:43:21 +0900 Subject: [PATCH] (concord-images-encode-url-as-id): Add optional argument `base'. (concord-images-add-url): Likewise. (concord-images-add-iiif): Likewise. --- concord-images.el | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/concord-images.el b/concord-images.el index e51775d..7597b07 100644 --- a/concord-images.el +++ b/concord-images.el @@ -1,8 +1,15 @@ (concord-assign-genre 'image-resource "/usr/local/var/photo/db") -(defun concord-images-encode-url-as-id (url) +(defun concord-images-encode-url-as-id (url &optional base) (let (ret) (cond + ((and base + (string-match (concat "^" (regexp-quote base)) url)) + (setq ret (substring url (match-end 0))) + (if (string-match "\\.[a-zA-Z0-9]+$" ret) + (substring ret 0 (match-beginning 0)) + ret) + ) ((string-match "^http://\\(hng\\|image\\)\\.\\(chise\\.org\\|kanji\\.zinbun\\.kyoto-u\\.ac\\.jp\\)/images/iiif/" url) (setq ret (substring url (match-end 0))) (if (string-match "\\.[a-zA-Z0-9]+$" ret) @@ -21,11 +28,11 @@ (t url)))) -(defun concord-images-add-url (url &optional iiif iip) +(defun concord-images-add-url (url &optional iiif iip base) (let (img-id img-cobj) (unless (setq img-cobj (concord-decode-object '=location url 'image-resource)) - (setq img-id (intern (concord-images-encode-url-as-id url))) + (setq img-id (intern (concord-images-encode-url-as-id url base))) (setq img-cobj (concord-make-object 'image-resource img-id)) (concord-object-put img-cobj '=location url) (when iiif @@ -50,11 +57,11 @@ ) img-cobj)) -(defun concord-images-add-iiif (url) +(defun concord-images-add-iiif (url &optional base) (let (img-id img-cobj) (unless (setq img-cobj (concord-decode-object '=location url 'image-resource)) - (setq img-id (intern (concord-images-encode-url-as-id url))) + (setq img-id (intern (concord-images-encode-url-as-id url base))) (setq img-cobj (concord-make-object 'image-resource img-id)) (concord-object-put img-cobj '=location@iiif url)) img-cobj)) -- 1.7.10.4