worblehat-old/lisp/marc.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")
|#