129 lines
4.0 KiB
Common Lisp
129 lines
4.0 KiB
Common Lisp
(in-package #:z3950)
|
|
|
|
(defun marc-ascii (record start end)
|
|
(babel:octets-to-string record :start start :end end))
|
|
|
|
(defun marc-number (record start end)
|
|
(values (parse-integer (marc-ascii record start end))))
|
|
|
|
(defun marc21-base-address (record)
|
|
(marc-number record 12 17))
|
|
|
|
(defun decode-subfield-code (octets)
|
|
(intern (string-upcase (babel:octets-to-string octets :encoding :marc-8))
|
|
"KEYWORD"))
|
|
|
|
(defun decode-marc21-subfields (field)
|
|
(assert (equal #x1e (aref field (1- (length field)))))
|
|
(loop
|
|
with start = 0
|
|
while (< start (1- (length field)))
|
|
for end = (or (position #x1f field :start start)
|
|
(1- (length field)))
|
|
collect (list (decode-subfield-code (subseq field start (1+ start)))
|
|
(babel:octets-to-string (subseq field (1+ start) end)
|
|
:encoding :marc-8))
|
|
do (setq start (1+ end))))
|
|
|
|
(defun decode-marc21-directory (record)
|
|
"List of (TAG LENGTH START) lists. TAG is a string, the other two
|
|
are integers. START is relative to the base address."
|
|
(assert (equal "4500" (marc-ascii record 20 24)))
|
|
(loop
|
|
for s from 24 below (position #x1e record :start 24) by 12
|
|
collect (list (marc-ascii record s (+ s 3))
|
|
(marc-number record (+ s 3) (+ s 7))
|
|
(marc-number record (+ s 7) (+ s 12)))))
|
|
|
|
(defun control-tag-p (tag)
|
|
(equal "00" (subseq tag 0 2)))
|
|
|
|
(defun decode-marc21-field (record tag start end)
|
|
(if (control-tag-p tag)
|
|
(list tag
|
|
(babel:octets-to-string (subseq record start end)
|
|
:encoding :marc-8))
|
|
(list tag
|
|
(babel:octets-to-string (subseq record start
|
|
(+ start 2))
|
|
:encoding :marc-8)
|
|
(decode-marc21-subfields (subseq record (+ start 3) end)))))
|
|
|
|
(defun decode-marc21 (record)
|
|
(assert (equal "22" (marc-ascii record 10 12)))
|
|
(let ((base (marc21-base-address record)))
|
|
(loop
|
|
for (tag length relative-start) in (decode-marc21-directory record)
|
|
for start = (+ base relative-start)
|
|
for end = (+ start length)
|
|
collect (decode-marc21-field record tag start end))))
|
|
|
|
(defun fields (marc tag &rest more-tags)
|
|
(let ((tags (cons tag more-tags)))
|
|
(remove-if-not (lambda (x) (member x tags :test #'equal)) marc
|
|
:key #'car)))
|
|
|
|
(defun subfield (contents subfield-code)
|
|
(cadr (assoc subfield-code contents)))
|
|
|
|
(defmacro with-subfields ((&rest subfields) contents &body body)
|
|
(alexandria:once-only (contents)
|
|
`(let ,(loop for symbol in subfields
|
|
collect `(,symbol
|
|
(cadr (assoc ,(intern (string symbol)
|
|
"KEYWORD")
|
|
,contents))))
|
|
,@body)))
|
|
|
|
;;; Mappings to Dublin Core, loosely based on
|
|
;;; http://www.loc.gov/marc/marc2dc.html.
|
|
|
|
(defun personal-name (contents)
|
|
(with-subfields (a b) contents
|
|
(if b
|
|
(format nil "~A ~A" a b)
|
|
a)))
|
|
|
|
(defun marc21-contributor (marc)
|
|
(loop
|
|
for (tag indicators contents) in (fields marc "100" "110" "111"
|
|
"700" "710" "711")
|
|
collect (string-trim ".," (if (equal (char tag 2) #\1)
|
|
(subfield contents :a)
|
|
(personal-name contents)))))
|
|
|
|
(defun marc21-title (marc)
|
|
(loop
|
|
for (tag indicators contents) in (fields marc "245" "246")
|
|
for title = (with-subfields (a b n p) contents
|
|
(format nil "~{~A~^ ~}" (remove nil (list a b n p))))
|
|
collect (let ((length (length title)))
|
|
(if (and (>= length 2)
|
|
(equal (subseq title (- length 2) length)
|
|
" /"))
|
|
(subseq title 0 (- (length title) 2))
|
|
title))))
|
|
|
|
(defun marc21-isbn (marc)
|
|
(loop
|
|
for (tag indicators contents) in (fields marc "020")
|
|
collect (subfield contents :a)))
|
|
|
|
(defun loc (isbn)
|
|
(z3950:with-open-connection (c "z3950.loc.gov:7090/Voyager")
|
|
(let ((rs (z3950:search-pqf c (format nil "@1=7 ~A" isbn))))
|
|
(when (> (z3950:result-set-size rs) 0)
|
|
(multiple-value-bind (octets syntax)
|
|
(z3950:result-set-record rs 0)
|
|
(assert (equal syntax "USmarc"))
|
|
(let ((marc (decode-marc21 octets)))
|
|
(values `((:contributor ,(marc21-contributor marc))
|
|
(:title ,(marc21-title marc))
|
|
(:identifier ,(marc21-isbn marc)))
|
|
marc octets)))))))
|
|
|
|
#|
|
|
(loc "9780201914658")
|
|
|#
|
|
|