272 lines
7.0 KiB
Common Lisp
272 lines
7.0 KiB
Common Lisp
|
||
(in-package #:z3950)
|
||
|
||
(define-foreign-library libyaz
|
||
(t (:default "libyaz.3")))
|
||
|
||
(use-foreign-library libyaz)
|
||
|
||
(defctype zoom-options :pointer)
|
||
|
||
(defcfun "ZOOM_options_create" zoom-options)
|
||
|
||
(defcfun "ZOOM_options_create_with_parent" zoom-options
|
||
(parent zoom-options))
|
||
|
||
(defcfun "ZOOM_options_destroy" :void
|
||
(opt zoom-options))
|
||
|
||
(defcfun "ZOOM_options_get" :string
|
||
(opt zoom-options)
|
||
(name :string))
|
||
|
||
(defcfun "ZOOM_options_set" :void
|
||
(opt zoom-options)
|
||
(name :string)
|
||
(v :string))
|
||
|
||
;; TODO: ZOOM_options_callback.
|
||
|
||
(defctype zoom-connection :pointer)
|
||
|
||
(defcfun "ZOOM_connection_new" zoom-connection
|
||
(host :string)
|
||
(portnum :int))
|
||
|
||
(defcfun "ZOOM_connection_create" zoom-connection
|
||
(options :pointer))
|
||
|
||
(defcfun "ZOOM_connection_connect" :void
|
||
(connection zoom-connection)
|
||
(host :string)
|
||
(portnum :int))
|
||
|
||
(defcfun "ZOOM_connection_destroy" :void
|
||
(connection zoom-connection))
|
||
|
||
(defctype string-ptr :pointer)
|
||
|
||
(defcfun "ZOOM_connection_error" :int
|
||
(connection zoom-connection)
|
||
(cp string-ptr)
|
||
(addinfo string-ptr))
|
||
|
||
(defcfun "ZOOM_connection_option_get" :string
|
||
(connection zoom-connection)
|
||
(key :string))
|
||
|
||
(defcfun "ZOOM_connection_option_set" :void
|
||
(connection zoom-connection)
|
||
(key :string)
|
||
(value :string))
|
||
|
||
(defctype zoom-query :pointer)
|
||
|
||
(defcfun "ZOOM_query_create" zoom-query)
|
||
|
||
(defcfun "ZOOM_query_destroy" :void
|
||
(query zoom-query))
|
||
|
||
(defcfun "ZOOM_query_prefix" :int
|
||
(query zoom-query)
|
||
(str :string))
|
||
|
||
(defcfun "ZOOM_query_cql" :int
|
||
(query zoom-query)
|
||
(str :string))
|
||
|
||
(defcfun "ZOOM_query_sortby" :int
|
||
(query zoom-query)
|
||
(criteria :string))
|
||
|
||
(defctype zoom-resultset :pointer)
|
||
|
||
(defcfun "ZOOM_connection_search" zoom-resultset
|
||
(connection zoom-connection)
|
||
(query zoom-query))
|
||
|
||
(defcfun "ZOOM_connection_search_pqf" zoom-resultset
|
||
(connection zoom-connection)
|
||
(q :string))
|
||
|
||
(defcfun "ZOOM_resultset_destroy" :void
|
||
(resultset zoom-resultset))
|
||
|
||
(defcfun "ZOOM_resultset_option_set" :void
|
||
(resultset zoom-resultset)
|
||
(key :string)
|
||
(val :string))
|
||
|
||
(defcfun "ZOOM_resultset_option_get" :string
|
||
(resultset zoom-resultset)
|
||
(key :string))
|
||
|
||
(defcfun "ZOOM_resultset_size" size
|
||
(resultset zoom-resultset))
|
||
|
||
(defctype zoom-record :pointer)
|
||
|
||
(defctype zoom-record-ptr :pointer)
|
||
|
||
(defcfun "ZOOM_resultset_records" :void
|
||
(resultset zoom-resultset)
|
||
(recs zoom-record-ptr)
|
||
(start size)
|
||
(count size))
|
||
|
||
(defcfun "ZOOM_resultset_record" zoom-record
|
||
(resultset zoom-resultset)
|
||
(pos size))
|
||
|
||
(defctype size-ptr :pointer)
|
||
|
||
(defcfun "ZOOM_record_get" :pointer
|
||
(record zoom-record)
|
||
(type :string)
|
||
(len size-ptr))
|
||
|
||
;; TODO: ZOOM_record_error.
|
||
|
||
(defcfun "ZOOM_record_clone" zoom-record
|
||
(rec zoom-record))
|
||
|
||
(defcfun "ZOOM_record_destroy" :void
|
||
(rec zoom-record))
|
||
|
||
;; TODO: Scan.
|
||
|
||
(defcfun "memcpy" :pointer
|
||
(dest :pointer)
|
||
(src :pointer)
|
||
(n size))
|
||
|
||
|
||
;;;
|
||
;;; Lisp API
|
||
;;;
|
||
|
||
(defclass connection ()
|
||
((foreign)
|
||
(charset :initarg :charset :accessor connection-charset)
|
||
(result-sets :initform nil :accessor connection-result-sets)))
|
||
|
||
(define-condition connection-error (error)
|
||
((cp :initarg :cp)
|
||
(addinfo :initarg :addinfo))
|
||
(:report (lambda (condition stream)
|
||
(with-slots (cp addinfo) condition
|
||
(format stream "~A: ~A" cp addinfo)))))
|
||
|
||
(defmethod check-for-connection-error ((c connection))
|
||
(with-slots (foreign) c
|
||
(cffi:with-foreign-object (cp :pointer)
|
||
(cffi:with-foreign-object (addinfo :pointer)
|
||
(unless (zerop (zoom-connection-error foreign cp addinfo))
|
||
(error 'connection-error
|
||
:cp (cffi:foreign-string-to-lisp (mem-ref cp :pointer))
|
||
:addinfo (cffi:foreign-string-to-lisp
|
||
(mem-ref addinfo :pointer))))))))
|
||
|
||
(defun connect (host &key port (charset :utf8))
|
||
(let ((c (make-instance 'connection :charset charset)))
|
||
(with-slots (foreign) c
|
||
(setf foreign (zoom-connection-create (cffi:null-pointer)))
|
||
(zoom-connection-connect foreign host (or port 0)))
|
||
(check-for-connection-error c)
|
||
c))
|
||
|
||
(defmethod disconnect ((c connection))
|
||
"Close the connection to the Z39.50 server."
|
||
(with-slots (result-sets foreign) c
|
||
(when foreign
|
||
(dolist (weak-ref result-sets)
|
||
(when #1=(trivial-garbage:weak-pointer-value weak-ref)
|
||
(close-result-set #1#)))
|
||
(zoom-connection-destroy foreign)
|
||
(setf foreign nil)
|
||
t)))
|
||
|
||
(defmacro with-open-connection ((var host &rest connect-args)
|
||
&body body)
|
||
`(let ((,var (connect ,host ,@connect-args)))
|
||
(unwind-protect (progn ,@body)
|
||
(disconnect ,var))))
|
||
|
||
(defmethod connection-host ((c connection))
|
||
(with-slots (foreign) c
|
||
(zoom-connection-option-get foreign "host")))
|
||
|
||
|
||
(defclass result-set ()
|
||
((foreign :initarg :foreign)
|
||
(connection :initarg :connection :reader result-set-connection)))
|
||
|
||
(defmethod initialize-instance :after ((rs result-set) &key)
|
||
(push (trivial-garbage:make-weak-pointer rs)
|
||
(connection-result-sets (result-set-connection rs))))
|
||
|
||
(defmethod close-result-set ((rs result-set))
|
||
(with-slots (foreign) rs
|
||
(when foreign
|
||
(zoom-resultset-destroy foreign)
|
||
(setf foreign nil)
|
||
t)))
|
||
|
||
(defmethod (setf result-set-preferred-record-syntax) (value (rs result-set))
|
||
(with-slots (foreign) rs
|
||
(zoom-resultset-option-set foreign "preferredRecordSyntax" value)))
|
||
|
||
(defmethod result-set-size ((rs result-set))
|
||
(with-slots (foreign) rs
|
||
(zoom-resultset-size foreign)))
|
||
|
||
(defmethod result-set-record ((rs result-set) i &key (form :raw))
|
||
(with-slots (foreign) rs
|
||
(let ((r (zoom-resultset-record foreign i)))
|
||
(let ((syntax (cffi:foreign-string-to-lisp
|
||
(zoom-record-get r "syntax" (cffi:null-pointer)))))
|
||
(with-foreign-object (len :int)
|
||
(let* ((src (zoom-record-get r (ecase form
|
||
(:raw "raw; charset=marc8"))
|
||
len))
|
||
(buf (cffi:make-shareable-byte-vector (cffi:mem-ref len
|
||
:int))))
|
||
(with-pointer-to-vector-data (dest buf)
|
||
(memcpy dest src (cffi:mem-ref len :int)))
|
||
(values buf syntax)))))))
|
||
|
||
(defmethod search-pqf ((c connection) (q string))
|
||
(make-instance 'result-set
|
||
:connection c
|
||
:foreign (with-slots (foreign) c
|
||
;; (let ((cffi:*default-foreign-encoding*
|
||
;; (connection-charset c)))
|
||
(zoom-connection-search-pqf foreign q)
|
||
;; )
|
||
)))
|
||
|
||
(defmacro with-query ((var) &body body)
|
||
`(let ((,var (zoom-query-create)))
|
||
(unwind-protect (progn ,@body)
|
||
(zoom-query-destroy ,var))))
|
||
|
||
(defmethod search-cql ((c connection) (query-string string))
|
||
(with-query (q)
|
||
(zoom-query-cql q query-string) ;; FIXME: Return value?
|
||
(with-slots (foreign) c
|
||
(make-instance 'result-set
|
||
:connection c
|
||
:foreign (zoom-connection-search foreign q)))))
|
||
|
||
|
||
(defun test-loc ()
|
||
(with-open-connection (c "z3950.loc.gov:7490/Voyager" :charset :latin1)
|
||
(let ((rs (search-pqf c "@1=4 \"Alt imellem\"")))
|
||
(setf (result-set-preferred-record-syntax rs) "MARC21")
|
||
(result-set-record rs 0))))
|
||
|
||
(defun test-bibsys ()
|
||
(with-open-connection (c "z3950.bibsys.no" :port 2100 :charset :latin1)
|
||
(let ((rs (search-pqf c "@1=4 \"Fru Inger til Østråt\"")))
|
||
(setf (result-set-preferred-record-syntax rs) "NORMARC")
|
||
(result-set-record rs 0)))) |