Begynnelse på Z39.50-grensesnitt (bruker libyaz), MARC-parser og dekoder
for tegnsettet MARC 8.
This commit is contained in:
parent
3a7130b794
commit
133f9bf1f5
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,551 @@
|
|||
(in-package #:z3950)
|
||||
|
||||
(babel-encodings::define-character-encoding :marc-8
|
||||
"Encoding developed incrementally since 1968 for use with the MARC
|
||||
format for bibliographic records. Although UTF-8 can now be used with
|
||||
MARC, many systems (including Library of Congress) still use the MARC
|
||||
8 encoding."
|
||||
)
|
||||
|
||||
|
||||
;;; Decoding tables.
|
||||
|
||||
(defconstant undef #xfffd)
|
||||
|
||||
(defparameter *basic-ascii-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents (loop for i from #x21 below #x7f collect i))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/42.html")
|
||||
|
||||
(defparameter *greek-symbols-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents `(,@(loop for i from #x21 below #x61 collect undef)
|
||||
#x03b1 #x03b2 #x03b3
|
||||
,@(loop for i from #x64 below #x7f collect undef)))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/2.html")
|
||||
|
||||
(defparameter *subscripts-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents
|
||||
`(,@(loop for marc-8 from #x21 below #x28 collect undef)
|
||||
#x208d #x208e ,undef #x208a ,undef #x208b ,undef ,undef
|
||||
,@(loop for marc-8 from #x30 below #x3a
|
||||
and ucs from #x2080
|
||||
collect ucs)
|
||||
,@(loop for marc-8 from #x3a below #x7f collect undef)))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/3.html")
|
||||
|
||||
(defparameter *superscripts-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents
|
||||
`(,@(loop for marc-8 from #x21 below #x28 collect undef)
|
||||
#x207d #x207e ,undef #x207a ,undef #x207b ,undef ,undef
|
||||
#x2070 #x00b9 #x00b2 #x00b3
|
||||
,@(loop for marc-8 from #x34 below #x3a
|
||||
and ucs from #x2074
|
||||
collect ucs)
|
||||
,@(loop for marc-8 from #x3a below #x7f collect undef)))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/4.html")
|
||||
|
||||
(defparameter *extended-latin-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents
|
||||
`(#x0141 #x00d8 #x0110 #x00de #x00c6 #x0152 #x02b9 ; a1--a7
|
||||
#x00b7 #x266d #x00ae #x00b1 #x01a0 #x01af #x02bc ,undef ; af
|
||||
#x02bb #x0142 #x00f8 #x0111 #x00fe #x00e6 #x0153 #x02ba ; b7
|
||||
#x0131 #x00a3 #x00f0 ,undef #x01a1 #x01b0 ,undef ,undef ; bf
|
||||
#x00b0 #x2113 #x2117 #x00a9 #x266f #x00bf #x00a1 #x00df ; c7
|
||||
#x20ac ,@(loop for i from #xc9 below #xe0 collect undef)
|
||||
#x0309 #x0300 #x0301 #x0302 #x0303 #x0304 #x0306 #x0307 ; e7
|
||||
#x0308 #x030c #x030a ; ea
|
||||
#xfe20 #xfe21 ; see note 1
|
||||
#x0315 #x030b #x0310 ; ef
|
||||
#x0327 #x0328 #x0323 #x0324 #x0325 #x0333 #x0332 #x0326 ; f7
|
||||
#x031c #x032e ; f9
|
||||
#xfe22 #xfe23 ; see note 2
|
||||
,undef ,undef #x0313))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/45.html")
|
||||
|
||||
(defparameter *basic-hebrew-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents
|
||||
`(#x21 #x05f4 #x23 #x24 #x25 #x26 #x05f3
|
||||
#x28 #x29 #x2a #x2b #x2c #x05be #x2e #x2f
|
||||
,@(loop for marc-8 from #x30 below #x40 collect marc-8)
|
||||
#x05b7 #x05b8 #x05b6 #x05b5 #x05b4 #x05b9 #x05bb #x05b0
|
||||
#x05b2 #x05b3 #x05b1 #x05bc #x05bf #x05c1 #xfb1e
|
||||
,@(loop for marc-8 from #x4f below #x5b collect undef)
|
||||
#x5b ,undef #x5d ,undef ,undef
|
||||
,@(loop for marc-8 from #x60 below #x7b and ucs from #x05d0
|
||||
collect ucs)
|
||||
#x05f0 #x05f1 #x05f2 ,undef))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/32.html")
|
||||
|
||||
(defparameter *basic-cyrillic-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents
|
||||
`(,@(loop for marc-8 from #x21 below #x40 collect marc-8)
|
||||
#x044e #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
|
||||
#x0445 #x0438 #x0439 #x043a #x043b #x043c #x043d #x043e
|
||||
#x043f #x044f #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
|
||||
#x044c #x044b #x0437 #x0448 #x044d #x0449 #x0447 #x044a
|
||||
#x042e #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
|
||||
#x0425 #x0418 #x0419 #x041a #x041b #x041c #x041d #x041e
|
||||
#x041f #x042f #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
|
||||
#x042c #x042b #x0417 #x0428 #x042d #x0429 #x0427))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/4E.html")
|
||||
|
||||
(defparameter *extended-cyrillic-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents
|
||||
`(,@(loop for i from #x21 below #x40 collect undef)
|
||||
#x0491 #x0452 #x0453 #x0454 #x0451 #x0455 #x0456 #x0457
|
||||
#x0458 #x0459 #x045A #x045B #x045C #x045E #x045F ,undef
|
||||
#x0463 #x0473 #x0475 #x046B
|
||||
,@(loop for i from #x54 below #x5b collect undef)
|
||||
#x005B ,undef #x005D ,undef #x005F
|
||||
#x0490 #x0402 #x0403 #x0404 #x0401 #x0405 #x0406 #x0407
|
||||
#x0408 #x0409 #x040A #x040B #x040C #x040E #x040F #x042A
|
||||
#x0462 #x0472 #x0474 #x046A
|
||||
,@(loop for i from #x74 below #x7f collect undef)))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/51.html")
|
||||
|
||||
(defparameter *basic-arabic-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents
|
||||
`(#x21 #x22 #x23 #x24 #x066a #x26 #x27
|
||||
#x28 #x29 #x066d #x2b #x060c #x2d #x2e #x2f
|
||||
#x0660 #x0661 #x0662 #x0663 #x0664 #x0665 #x0666 #x0667
|
||||
#x0668 #x0669 #x003a #x061b #x003c #x003d #x003e #x061f
|
||||
,undef
|
||||
,@(loop for m from #x41 below #x5b and ucs from #x0621 collect ucs)
|
||||
#x5b ,undef #xfd ,undef ,undef
|
||||
,@(loop for m from #x60 below #x73 and ucs from #x0640 collect ucs)
|
||||
#x0671 #x0670 ,undef ,undef ,undef
|
||||
#x066c #x201d #x201c ,undef ,undef ,undef ,undef))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/33.html")
|
||||
|
||||
(defparameter *extended-arabic-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents
|
||||
`(#x06fd #x0672 #x0673
|
||||
,@(loop for m from #x24 below #x32 and ucs from #x0679 collect ucs)
|
||||
#x06bf
|
||||
,@(loop for m from #x33 below #x49 and u from #x0687 collect u)
|
||||
#x06fa #x069d #x069e #x06fb #x069f #x06a0 #x06fc
|
||||
,@(loop for m from #x50 below #x6c and u from #x06a1 collect u)
|
||||
#x06b9 #x06be #x06c0 #x06c4
|
||||
#x06c5 #x06c6 #x06ca #x06cb #x06cd #x06ce #x06d0 #x06d2
|
||||
#x06d3 ,undef ,undef ,undef ,undef #x0306 #x030c))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/34.html")
|
||||
|
||||
(defparameter *basic-greek-decode-table*
|
||||
(make-array
|
||||
#x5e :element-type '(unsigned-byte 16)
|
||||
:initial-contents
|
||||
`( #x0300 #x0301 #x0308 #x0342 #x0313 #x0314 #x0345
|
||||
,undef ,undef ,undef ,undef ,undef ,undef ,undef ,undef
|
||||
#x00ab #x00bb #x201c #x201d #x0374 #x0375 ,undef ,undef
|
||||
,undef ,undef ,undef #x0387 ,undef ,undef ,undef #x037e
|
||||
,undef #x0391 #x0392 ,undef #x0393 #x0394 #x0395 #x03da
|
||||
#x03dc #x0396 #x0397 #x0398 #x0399 #x039a #x039b #x039c
|
||||
#x039d #x039e #x039f #x03a0 #x03de #x03a1 #x03a3 ,undef
|
||||
#x03a4 #x03a5 #x03a6 #x03a7 #x03a8 #x03a9 #x03e0 ,undef
|
||||
,undef #x03b1 #x03b2 #x03d0 #x03b3 #x03b4 #x03b5 #x03db
|
||||
#x03dd #x03b6 #x03b7 #x03b8 #x03b9 #x03ba #x03bb #x03bc
|
||||
#x03bd #x03be #x03bf #x03c0 #x03df #x03c1 #x03c3 #x03c2
|
||||
#x03c4 #x03c5 #x03c6 #x03c7 #x03c8 #x03c9 #x03e1))
|
||||
"http://lcweb2.loc.gov/diglib/codetables/53.html")
|
||||
|
||||
(defparameter *eacc-decode-table*
|
||||
(let ((ht (make-hash-table)))
|
||||
(with-open-file (input (asdf:system-relative-pathname '#:z3950
|
||||
#p"eacc2uni.txt"))
|
||||
(let ((start 0) end m u)
|
||||
(loop
|
||||
for line = (read-line input nil nil)
|
||||
while line
|
||||
do
|
||||
(setq end (position #\, line)
|
||||
m (parse-integer line :end end :radix 16)
|
||||
start (1+ end)
|
||||
end (position #\, line :start start)
|
||||
u (parse-integer line :start start :end end :radix 16))
|
||||
(setf (gethash m ht) u))))
|
||||
ht)
|
||||
"http://www.loc.gov/marc/specifications/specchareacc.html")
|
||||
|
||||
|
||||
;;; Decoder.
|
||||
|
||||
(defmacro illegal-escape (getter src i)
|
||||
(alexandria:with-unique-names (j m)
|
||||
`(error "Illegal escape sequence:~{ ~X~}"
|
||||
(reverse (loop with ,j = ,i
|
||||
for ,m = (,getter ,src (decf ,j))
|
||||
collect ,m
|
||||
until (= ,m #x1b))))))
|
||||
|
||||
(babel-encodings::define-code-point-counter :marc-8 (getter type)
|
||||
`(lambda (seq start end max)
|
||||
(declare (type ,type seq) (fixnum start end max))
|
||||
(let ((nchars 0)
|
||||
(g0-width 1)
|
||||
(g1-width 1)
|
||||
(i start))
|
||||
(macrolet ((input () `(prog1 (,',getter seq i) (incf i))))
|
||||
(tagbody
|
||||
start
|
||||
(when (= i end)
|
||||
(go accept))
|
||||
(let ((m (input)))
|
||||
(cond ((= m #x1b) (go esc))
|
||||
((or (= m #xa0) (= m #xff)) (go reserved))
|
||||
((< m #x21)
|
||||
(incf nchars)
|
||||
(go start))
|
||||
((< m #x7f) (cond ((= g0-width 1)
|
||||
(incf nchars)
|
||||
(go start))
|
||||
(t (go triple-2))))
|
||||
((< m #xa1)
|
||||
(incf nchars)
|
||||
(go start))
|
||||
(t (cond ((= g1-width 1)
|
||||
(incf nchars)
|
||||
(go start))
|
||||
(t (go triple-2))))))
|
||||
esc
|
||||
(when (= i end)
|
||||
(go illegal-escape))
|
||||
(case (input)
|
||||
((#x67 #x62 #x70 #x73) (go start))
|
||||
((#x28 #x2c #x29 #x2d) (go intermediate-single-1))
|
||||
(#x24 (go intermediate-multiple-1))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-single-1
|
||||
(when (= i end)
|
||||
(go illegal-escape))
|
||||
(case (input)
|
||||
((#x33 #x34 #x42 #x4e #x51 #x53 #x32) (go start))
|
||||
(#x21 (go intermediate-single-2))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-single-2
|
||||
(when (= i end)
|
||||
(go illegal-escape))
|
||||
(case (input)
|
||||
(#x45 (go start))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-multiple-1
|
||||
(when (= i end)
|
||||
(go illegal-escape))
|
||||
(case (input)
|
||||
(#x2c (go intermediate-multiple-2-g0))
|
||||
(#x31 (setf g0-width 3)
|
||||
(go start))
|
||||
((#x29 #x2d) (go intermediate-multiple-2-g1))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-multiple-2-g0
|
||||
(when (= i end)
|
||||
(go illegal-escape))
|
||||
(case (input)
|
||||
(#x31 (setf g0-width 3)
|
||||
(go start))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-multiple-2-g1
|
||||
(when (= i end)
|
||||
(go illegal-escape))
|
||||
(case (input)
|
||||
(#x31 (setf g1-width 3)
|
||||
(go start))
|
||||
(t (go illegal-escape)))
|
||||
triple-2
|
||||
(when (= i end)
|
||||
(go partial))
|
||||
(input)
|
||||
(go triple-3)
|
||||
triple-3
|
||||
(when (= i end)
|
||||
(go partial))
|
||||
(input)
|
||||
(incf nchars)
|
||||
(go start)
|
||||
partial
|
||||
(error "Partial multiple-byte character.")
|
||||
reserved
|
||||
(error "~D is a reserved value and must not be used in MARC 8-encoded records." (,getter seq (1- i)))
|
||||
illegal-escape
|
||||
(illegal-escape ,getter seq i)
|
||||
accept
|
||||
))
|
||||
(values nchars end))))
|
||||
|
||||
(babel-encodings::define-decoder :marc-8 (getter src-type setter dest-type)
|
||||
`(lambda (src start end dest d-start)
|
||||
(declare (type ,src-type src)
|
||||
(type ,dest-type dest)
|
||||
(fixnum start end d-start))
|
||||
(let ((g0 *basic-ascii-decode-table*)
|
||||
(g1 *extended-latin-decode-table*)
|
||||
m
|
||||
(g0-width 1) (g1-width 1)
|
||||
(i start)
|
||||
(di d-start))
|
||||
(labels ((iso2022 (u)
|
||||
(ecase u
|
||||
(#x33 *basic-arabic-decode-table*)
|
||||
(#x34 *extended-arabic-decode-table*)
|
||||
(#x42 *basic-ascii-decode-table*)
|
||||
(#x21 (case (,getter src (incf i))
|
||||
(#x45 *extended-latin-decode-table*)
|
||||
(t (illegal-escape ,getter src i))))
|
||||
(#x31 *eacc-decode-table*)
|
||||
(#x4e *basic-cyrillic-decode-table*)
|
||||
(#x51 *extended-cyrillic-decode-table*)
|
||||
(#x53 *basic-greek-decode-table*)
|
||||
(#x32 *basic-hebrew-decode-table*))))
|
||||
(macrolet ((input () `(prog1 (,',getter src i) (incf i))))
|
||||
(tagbody
|
||||
start
|
||||
(when (= i end) (go accept))
|
||||
(setq m (input))
|
||||
(cond
|
||||
((= m #x1b) (go esc))
|
||||
((or (= m #xa0) (= m #xff)) (go reserved))
|
||||
((< m #x21)
|
||||
(,setter m dest di)
|
||||
(incf di)
|
||||
(go start))
|
||||
((< m #x7f) (cond ((= g0-width 1)
|
||||
(,setter (aref g0 (- m #x21)) dest di)
|
||||
(incf di)
|
||||
(go start))
|
||||
(t (go triple-2-g0))))
|
||||
((< m #xa1)
|
||||
(,setter m dest di)
|
||||
(incf di)
|
||||
(go start))
|
||||
(t (cond ((= g1-width 1)
|
||||
(,setter (aref g1 (- m #xa1)) dest di)
|
||||
(incf di)
|
||||
(go start))
|
||||
(t (go triple-2-g1)))))
|
||||
esc
|
||||
(when (= i end) (go illegal-escape))
|
||||
(case (input)
|
||||
(#x67 (setf g0 *basic-greek-decode-table*
|
||||
g0-width 1)
|
||||
(go start))
|
||||
(#x62 (setf g0 *subscripts-decode-table*
|
||||
g0-width 1)
|
||||
(go start))
|
||||
(#x70 (setf g0 *superscripts-decode-table*
|
||||
g0-width 1)
|
||||
(go start))
|
||||
(#x73 (setf g0 *basic-ascii-decode-table*
|
||||
g0-width 1)
|
||||
(go start))
|
||||
((#x28 #x2c)
|
||||
(go intermediate-single-1-g0))
|
||||
((#x29 #x2d)
|
||||
(go intermediate-single-1-g1))
|
||||
(#x24 (go intermediate-multiple-1))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-single-1-g0
|
||||
(when (= i end) (go illegal-escape))
|
||||
(case (input)
|
||||
((#x33 #x34 #x42 #x4e #x51 #x53 #x32)
|
||||
(setf g0 (iso2022 (,getter src (1- i)))
|
||||
g0-width 1)
|
||||
(go start))
|
||||
(#x21 (go intermediate-single-2-g0))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-single-1-g1
|
||||
(when (= i end) (go illegal-escape))
|
||||
(case (input)
|
||||
((#x33 #x34 #x42 #x4e #x51 #x53 #x32)
|
||||
(setf g1 (iso2022 (,getter src (1- i)))
|
||||
g1-width 1)
|
||||
(go start))
|
||||
(#x21 (go intermediate-single-2-g1))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-single-2-g0
|
||||
(when (= i end) (go illegal-escape))
|
||||
(case (input)
|
||||
(#x45 (setf g0 *extended-latin-decode-table*
|
||||
g0-width 1)
|
||||
(go start))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-single-2-g1
|
||||
(when (= i end) (go illegal-escape))
|
||||
(case (input)
|
||||
(#x45 (setf g1 *extended-latin-decode-table*
|
||||
g1-width 1)
|
||||
(go start))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-multiple-1
|
||||
(when (= i end) (go illegal-escape))
|
||||
(case (input)
|
||||
(#x2c (go intermediate-multiple-2-g0))
|
||||
((#x29 #x2d) (go intermediate-multiple-2-g1))
|
||||
(#x31 (setf g0 *eacc-decode-table*
|
||||
g0-width 3)
|
||||
(go start))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-multiple-2-g0
|
||||
(when (= i end) (go illegal-escape))
|
||||
(case (input)
|
||||
(#x31 (setf g0 *eacc-decode-table*
|
||||
g0-width 3)
|
||||
(go start))
|
||||
(t (go illegal-escape)))
|
||||
intermediate-multiple-2-g1
|
||||
(when (= i end) (go illegal-escape))
|
||||
(case (input)
|
||||
(#x31 (setf g1 *eacc-decode-table*
|
||||
g1-width 3)
|
||||
(go start))
|
||||
(t (go illegal-escape)))
|
||||
triple-2-g0
|
||||
(when (= i end)
|
||||
(go partial))
|
||||
(input)
|
||||
(go triple-3-g0)
|
||||
triple-2-g1
|
||||
(when (= i end)
|
||||
(go partial))
|
||||
(input)
|
||||
(go triple-3-g1)
|
||||
triple-3-g0
|
||||
(when (= i end)
|
||||
(go partial))
|
||||
(input)
|
||||
(let* ((m1 (,getter src (- i 3)))
|
||||
(m2 (,getter src (- i 2)))
|
||||
(m3 (,getter src (- i 1)))
|
||||
(key (+ (* (+ (* m1 #x100) m2) #x100) m3)))
|
||||
(,setter (or (gethash key g0 nil) ,undef)
|
||||
dest di)
|
||||
(incf di))
|
||||
(go start)
|
||||
triple-3-g1
|
||||
(when (= i end)
|
||||
(go partial))
|
||||
(input)
|
||||
(let* ((m1 (- (,getter src (- i 3)) #x80))
|
||||
(m2 (- (,getter src (- i 2)) #x80))
|
||||
(m3 (- (,getter src (- i 1)) #x80))
|
||||
(key (+ (* (+ (* m1 #x100) m2) #x100) m3)))
|
||||
(,setter (or (gethash key g1 nil) ,undef)
|
||||
dest di)
|
||||
(incf di))
|
||||
(go start)
|
||||
partial
|
||||
(error "Partial multiple-byte character.")
|
||||
reserved
|
||||
(error "~D is a reserved value and must not be used in MARC 8-encoded records." (,getter src (1- i)))
|
||||
illegal-escape
|
||||
(illegal-escape ,getter src i)
|
||||
accept
|
||||
))))))
|
||||
|
||||
;;; This seems to be the only way to get Babel to use the new decoder.
|
||||
|
||||
(defparameter babel::*string-vector-mappings*
|
||||
(babel-encodings:instantiate-concrete-mappings
|
||||
:octet-seq-setter babel::ub-set
|
||||
:octet-seq-getter babel::ub-get
|
||||
:octet-seq-type (simple-array (unsigned-byte 8) (*))
|
||||
:code-point-seq-setter babel::string-set
|
||||
:code-point-seq-getter babel::string-get
|
||||
:code-point-seq-type babel:simple-unicode-string))
|
||||
|
||||
|
||||
;;; Testing.
|
||||
|
||||
(defun ub8v (&rest numbers)
|
||||
(make-array (length numbers) :element-type '(unsigned-byte 8)
|
||||
:initial-contents numbers))
|
||||
|
||||
(defun ub16v (&rest numbers)
|
||||
(make-array (length numbers) :element-type '(unsigned-byte 16)
|
||||
:initial-contents numbers))
|
||||
|
||||
(defun test-kjorbye-marc-8 ()
|
||||
(ub8v 75 105 178 114 98 121 101 32 66 101 114 116 101 108 115 101 110 44
|
||||
32 73 110 103 101 114))
|
||||
|
||||
(defun eacc (s)
|
||||
(let* ((key (+ (* (+ (* (char-code (char s 0)) #x100)
|
||||
(char-code (char s 1))) #x100)
|
||||
(char-code (char s 2))))
|
||||
(value (gethash key *eacc-decode-table*)))
|
||||
(format t "~x~%" value)
|
||||
(code-char value)))
|
||||
|
||||
(define-test decode
|
||||
(assert-equal "Kiørbye Bertelsen, Inger"
|
||||
(babel:octets-to-string (test-kjorbye-marc-8)
|
||||
:encoding :marc-8))
|
||||
(assert-equal "β-tubulin"
|
||||
(babel:octets-to-string (babel:string-to-octets
|
||||
"gbs-tubulin")
|
||||
:encoding :marc-8))
|
||||
(assert-equal "羅貫中 ; 張亦文譯."
|
||||
(babel:octets-to-string (babel:string-to-octets "$1!R7!Yn!04(B ; $1!=G!0\\!BX!YF(B.")
|
||||
:encoding :marc-8))
|
||||
(assert-equal "羅貫中 ; 張亦文譯."
|
||||
(babel:octets-to-string (babel:string-to-octets "$)1¡Ò·¡Ùî¡°´ ; ¡½Ç¡°Ü¡ÂØ¡ÙÆ)!E." :encoding :latin-1)
|
||||
:encoding :marc-8)))
|
||||
|
||||
|
||||
(define-test encode
|
||||
(assert-equalp (test-kjorbye-marc-8)
|
||||
(babel:string-to-octets "Kiørbye Bertelsen, Inger"
|
||||
:encoding :marc-8))
|
||||
(assert-equal "gbs-tubulin"
|
||||
(babel:octets-to-string
|
||||
(babel:string-to-octets "β-tubulin" :encoding :marc-8))))
|
||||
|
||||
|
||||
;;; Unicode normalization.
|
||||
|
||||
(defun tt-to-number (line)
|
||||
(multiple-value-bind (a b c d) (ppcre:scan "<tt>([^<]+)</tt>" line)
|
||||
(declare (ignore a b))
|
||||
(loop
|
||||
with start = (aref c 0)
|
||||
while (> (aref d 0) start)
|
||||
for end = (or (position #\Space line :start start :end (aref d 0))
|
||||
(aref d 0))
|
||||
collect (parse-integer line :start start :end end :radix 16)
|
||||
do (setf start (1+ end)))))
|
||||
|
||||
(defun read-normalization-table ()
|
||||
(with-open-file (stream "/Users/ljosa/tmp/chart_Latin.html")
|
||||
(let ((result nil))
|
||||
(tagbody
|
||||
(loop
|
||||
for line = (read-line stream nil nil)
|
||||
when (not line)
|
||||
do (go done)
|
||||
until (string-equal line "<tr>"))
|
||||
(let ((a (tt-to-number (read-line stream)))
|
||||
(b (tt-to-number (read-line stream)))
|
||||
(c (tt-to-number (read-line stream)))
|
||||
(d (tt-to-number (read-line stream)))
|
||||
(e (tt-to-number (read-line stream))))
|
||||
(declare (ignore a d e))
|
||||
(push (list b c) result))
|
||||
done)
|
||||
(nreverse result))))
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
(flag "-I/opt/local/include")
|
||||
(include "yaz/zoom.h")
|
||||
|
||||
(in-package #:z3950)
|
||||
|
||||
(ctype size "size_t")
|
||||
|
|
@ -0,0 +1,272 @@
|
|||
|
||||
(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))))
|
||||
|
|
@ -0,0 +1,429 @@
|
|||
;;;-*- Mode: Lisp; Package: LISP-UNIT -*-
|
||||
|
||||
#|
|
||||
Copyright (c) 2004-2005 Christopher K. Riesbeck
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining
|
||||
a copy of this software and associated documentation files (the "Software"),
|
||||
to deal in the Software without restriction, including without limitation
|
||||
the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
||||
and/or sell copies of the Software, and to permit persons to whom the
|
||||
Software is furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included
|
||||
in all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
|
||||
OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
||||
THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
|
||||
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
|
||||
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
|
||||
OTHER DEALINGS IN THE SOFTWARE.
|
||||
|#
|
||||
|
||||
|
||||
;;; A test suite package, modelled after JUnit.
|
||||
;;; Author: Chris Riesbeck
|
||||
;;;
|
||||
;;; Update history:
|
||||
;;;
|
||||
;;; 04/07/06 added ~<...~> to remaining error output forms [CKR]
|
||||
;;; 04/06/06 added ~<...~> to compact error output better [CKR]
|
||||
;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported
|
||||
;;; by Daniel Edward Burke) [CKR]
|
||||
;;; 02/08/06 added newlines to error output [CKR]
|
||||
;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR]
|
||||
;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR]
|
||||
;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger,
|
||||
;;; 11/07/05 added *use-debugger* and assert-predicate [DFB]
|
||||
;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR]
|
||||
;;; 08/30/05 added license notice [CKR]
|
||||
;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR]
|
||||
;;; 02/21/05 removed length check from SET-EQUAL [CKR]
|
||||
;;; 02/17/05 added RUN-ALL-TESTS [CKR]
|
||||
;;; 01/18/05 added ASSERT-EQUAL back in [CKR]
|
||||
;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR]
|
||||
;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR]
|
||||
;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR]
|
||||
;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR]
|
||||
;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR]
|
||||
;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR]
|
||||
;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR]
|
||||
;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR]
|
||||
;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR]
|
||||
;;; 12/02/04 changed to group tests under packages [CKR]
|
||||
;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR]
|
||||
;;; 11/30/04 improved error handling and summarization [CKR]
|
||||
;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR]
|
||||
;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR]
|
||||
;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR]
|
||||
;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR]
|
||||
;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR]
|
||||
;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR]
|
||||
;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR]
|
||||
;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR]
|
||||
|
||||
|
||||
#|
|
||||
How to use
|
||||
----------
|
||||
|
||||
1. Read the documentation in lisp-unit.html.
|
||||
|
||||
2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
|
||||
examples. If you want, start your test file with (REMOVE-TESTS) to
|
||||
clear any previously defined tests.
|
||||
|
||||
2. Load this file.
|
||||
|
||||
2. (use-package :lisp-unit)
|
||||
|
||||
3. Load your code file and your file of tests.
|
||||
|
||||
4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! --
|
||||
or simply (RUN-TESTS) to run all defined tests.
|
||||
|
||||
A summary of how many tests passed and failed will be printed,
|
||||
with details on the failures.
|
||||
|
||||
Note: Nothing is compiled until RUN-TESTS is expanded. Redefining
|
||||
functions or even macros does not require reloading any tests.
|
||||
|
||||
For more information, see lisp-unit.html.
|
||||
|
||||
|#
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Packages
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(cl:defpackage #:lisp-unit
|
||||
(:use #:common-lisp)
|
||||
(:export #:define-test #:run-all-tests #:run-tests
|
||||
#:assert-eq #:assert-eql #:assert-equal #:assert-equalp
|
||||
#:assert-error #:assert-expands #:assert-false
|
||||
#:assert-equality #:assert-prints #:assert-true
|
||||
#:get-test-code #:get-tests
|
||||
#:remove-all-tests #:remove-tests
|
||||
#:logically-equal #:set-equal
|
||||
#:use-debugger
|
||||
#:with-test-listener)
|
||||
)
|
||||
|
||||
(in-package #:lisp-unit)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Globals
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defparameter *test-listener* nil)
|
||||
|
||||
(defparameter *tests* (make-hash-table))
|
||||
|
||||
;;; Used by RUN-TESTS to collect summary statistics
|
||||
(defvar *test-count* 0)
|
||||
(defvar *pass-count* 0)
|
||||
|
||||
;;; Set by RUN-TESTS for use by SHOW-FAILURE
|
||||
(defvar *test-name* nil)
|
||||
|
||||
;;; If nil, errors in tests are caught and counted.
|
||||
;;; If :ask, user is given option of entering debugger or not.
|
||||
;;; If true and not :ask, debugger is entered.
|
||||
(defparameter *use-debugger* nil)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Macros
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; DEFINE-TEST
|
||||
|
||||
(defmacro define-test (name &body body)
|
||||
`(progn
|
||||
(store-test-code ',name ',body)
|
||||
',name))
|
||||
|
||||
;;; ASSERT macros
|
||||
|
||||
(defmacro assert-eq (expected form &rest extras)
|
||||
(expand-assert :equal form form expected extras :test #'eq))
|
||||
|
||||
(defmacro assert-eql (expected form &rest extras)
|
||||
(expand-assert :equal form form expected extras :test #'eql))
|
||||
|
||||
(defmacro assert-equal (expected form &rest extras)
|
||||
(expand-assert :equal form form expected extras :test #'equal))
|
||||
|
||||
(defmacro assert-equalp (expected form &rest extras)
|
||||
(expand-assert :equal form form expected extras :test #'equalp))
|
||||
|
||||
(defmacro assert-error (condition form &rest extras)
|
||||
(expand-assert :error form (expand-error-form form)
|
||||
condition extras))
|
||||
|
||||
(defmacro assert-expands (&environment env expansion form &rest extras)
|
||||
(expand-assert :macro form
|
||||
(expand-macro-form form #+lispworks nil #-lispworks env)
|
||||
expansion extras))
|
||||
|
||||
(defmacro assert-false (form &rest extras)
|
||||
(expand-assert :result form form nil extras))
|
||||
|
||||
(defmacro assert-equality (test expected form &rest extras)
|
||||
(expand-assert :equal form form expected extras :test test))
|
||||
|
||||
(defmacro assert-prints (output form &rest extras)
|
||||
(expand-assert :output form (expand-output-form form)
|
||||
output extras))
|
||||
|
||||
(defmacro assert-true (form &rest extras)
|
||||
(expand-assert :result form form t extras))
|
||||
|
||||
|
||||
(defun expand-assert (type form body expected extras &key (test #'eql))
|
||||
`(internal-assert
|
||||
,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test))
|
||||
|
||||
(defun expand-error-form (form)
|
||||
`(handler-case ,form
|
||||
(condition (error) error)))
|
||||
|
||||
(defun expand-output-form (form)
|
||||
(let ((out (gensym)))
|
||||
`(let* ((,out (make-string-output-stream))
|
||||
(*standard-output* (make-broadcast-stream *standard-output* ,out)))
|
||||
,form
|
||||
(get-output-stream-string ,out))))
|
||||
|
||||
(defun expand-macro-form (form env)
|
||||
`(macroexpand-1 ',form ,env))
|
||||
|
||||
(defun expand-extras (extras)
|
||||
`#'(lambda ()
|
||||
(list ,@(mapcan #'(lambda (form) (list `',form form)) extras))))
|
||||
|
||||
|
||||
;;; RUN-TESTS
|
||||
|
||||
(defmacro run-all-tests (package &rest tests)
|
||||
`(let ((*package* (find-package ',package)))
|
||||
(run-tests
|
||||
,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package))
|
||||
tests))))
|
||||
|
||||
(defmacro run-tests (&rest names)
|
||||
`(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names))))
|
||||
|
||||
(defun get-test-thunks (names &optional (package *package*))
|
||||
(mapcar #'(lambda (name) (get-test-thunk name package))
|
||||
names))
|
||||
|
||||
(defun get-test-thunk (name package)
|
||||
(assert (get-test-code name package) (name package)
|
||||
"No test defined for ~S in package ~S" name package)
|
||||
(list name (coerce `(lambda () ,@(get-test-code name)) 'function)))
|
||||
|
||||
(defun use-debugger (&optional (flag t))
|
||||
(setq *use-debugger* flag))
|
||||
|
||||
;;; WITH-TEST-LISTENER
|
||||
(defmacro with-test-listener (listener &body body)
|
||||
`(let ((*test-listener* #',listener)) ,@body))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Public functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun get-test-code (name &optional (package *package*))
|
||||
(let ((table (get-package-table package)))
|
||||
(unless (null table)
|
||||
(gethash name table))))
|
||||
|
||||
(defun get-tests (&optional (package *package*))
|
||||
(let ((l nil)
|
||||
(table (get-package-table package)))
|
||||
(cond ((null table) nil)
|
||||
(t
|
||||
(maphash #'(lambda (key val)
|
||||
(declare (ignore val))
|
||||
(push key l))
|
||||
table)
|
||||
(sort l #'string< :key #'string)))))
|
||||
|
||||
|
||||
(defun remove-tests (names &optional (package *package*))
|
||||
(let ((table (get-package-table package)))
|
||||
(unless (null table)
|
||||
(if (null names)
|
||||
(clrhash table)
|
||||
(dolist (name names)
|
||||
(remhash name table))))))
|
||||
|
||||
(defun remove-all-tests (&optional (package *package*))
|
||||
(if (null package)
|
||||
(clrhash *tests*)
|
||||
(remhash (find-package package) *tests*)))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Private functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;;; DEFINE-TEST support
|
||||
|
||||
(defun get-package-table (package &key create)
|
||||
(let ((table (gethash (find-package package) *tests*)))
|
||||
(or table
|
||||
(and create
|
||||
(setf (gethash package *tests*)
|
||||
(make-hash-table))))))
|
||||
|
||||
(defun get-test-name (form)
|
||||
(if (atom form) form (cadr form)))
|
||||
|
||||
(defun store-test-code (name code &optional (package *package*))
|
||||
(setf (gethash name
|
||||
(get-package-table package :create t))
|
||||
code))
|
||||
|
||||
|
||||
;;; ASSERTION support
|
||||
|
||||
(defun internal-assert (type form code-thunk expected-thunk extras test)
|
||||
(let* ((expected (multiple-value-list (funcall expected-thunk)))
|
||||
(actual (multiple-value-list (funcall code-thunk)))
|
||||
(passed (test-passed-p type expected actual test)))
|
||||
|
||||
(incf *test-count*)
|
||||
(when passed
|
||||
(incf *pass-count*))
|
||||
|
||||
(record-result passed type form expected actual extras)
|
||||
|
||||
passed))
|
||||
|
||||
(defun record-result (passed type form expected actual extras)
|
||||
(funcall (or *test-listener* 'default-listener)
|
||||
passed type *test-name* form expected actual
|
||||
(and extras (funcall extras))
|
||||
*test-count* *pass-count*))
|
||||
|
||||
(defun default-listener
|
||||
(passed type name form expected actual extras test-count pass-count)
|
||||
(declare (ignore test-count pass-count))
|
||||
(unless passed
|
||||
(show-failure type (get-failure-message type)
|
||||
name form expected actual extras)))
|
||||
|
||||
(defun test-passed-p (type expected actual test)
|
||||
(ecase type
|
||||
(:error
|
||||
(or (eql (car actual) (car expected))
|
||||
(typep (car actual) (car expected))))
|
||||
(:equal
|
||||
(and (<= (length expected) (length actual))
|
||||
(every test expected actual)))
|
||||
(:macro
|
||||
(equal (car actual) (car expected)))
|
||||
(:output
|
||||
(string= (string-trim '(#\newline #\return #\space)
|
||||
(car actual))
|
||||
(car expected)))
|
||||
(:result
|
||||
(logically-equal (car actual) (car expected)))
|
||||
))
|
||||
|
||||
|
||||
;;; RUN-TESTS support
|
||||
|
||||
(defun run-test-thunks (test-thunks)
|
||||
(unless (null test-thunks)
|
||||
(let ((total-test-count 0)
|
||||
(total-pass-count 0)
|
||||
(total-error-count 0))
|
||||
(dolist (test-thunk test-thunks)
|
||||
(multiple-value-bind (test-count pass-count error-count)
|
||||
(run-test-thunk (car test-thunk) (cadr test-thunk))
|
||||
(incf total-test-count test-count)
|
||||
(incf total-pass-count pass-count)
|
||||
(incf total-error-count error-count)))
|
||||
(unless (null (cdr test-thunks))
|
||||
(show-summary 'total total-test-count total-pass-count total-error-count))
|
||||
(values))))
|
||||
|
||||
(defun run-test-thunk (*test-name* thunk)
|
||||
(if (null thunk)
|
||||
(format t "~& Test ~S not found" *test-name*)
|
||||
(prog ((*test-count* 0)
|
||||
(*pass-count* 0)
|
||||
(error-count 0))
|
||||
(handler-bind
|
||||
((error #'(lambda (e)
|
||||
(let ((*print-escape* nil))
|
||||
(setq error-count 1)
|
||||
(format t "~& ~S: ~W" *test-name* e))
|
||||
(if (use-debugger-p e) e (go exit)))))
|
||||
(funcall thunk)
|
||||
(show-summary *test-name* *test-count* *pass-count*))
|
||||
exit
|
||||
(return (values *test-count* *pass-count* error-count)))))
|
||||
|
||||
(defun use-debugger-p (e)
|
||||
(and *use-debugger*
|
||||
(or (not (eql *use-debugger* :ask))
|
||||
(y-or-n-p "~A -- debug?" e))))
|
||||
|
||||
;;; OUTPUT support
|
||||
|
||||
(defun get-failure-message (type)
|
||||
(case type
|
||||
(:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
|
||||
(:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
|
||||
(:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
|
||||
(t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
|
||||
))
|
||||
|
||||
(defun show-failure (type msg name form expected actual extras)
|
||||
(format t "~&~@[~S: ~]~S failed: " name form)
|
||||
(format t msg expected actual)
|
||||
(format t "~{~& ~S => ~S~}~%" extras)
|
||||
type)
|
||||
|
||||
(defun show-summary (name test-count pass-count &optional error-count)
|
||||
(format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]."
|
||||
name pass-count (- test-count pass-count) error-count))
|
||||
|
||||
(defun collect-form-values (form values)
|
||||
(mapcan #'(lambda (form-arg value)
|
||||
(if (constantp form-arg)
|
||||
nil
|
||||
(list form-arg value)))
|
||||
(cdr form)
|
||||
values))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Useful equality predicates for tests
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; (LOGICALLY-EQUAL x y) => true or false
|
||||
;;; Return true if x and y both false or both true
|
||||
|
||||
(defun logically-equal (x y)
|
||||
(eql (not x) (not y)))
|
||||
|
||||
;;; (SET-EQUAL l1 l2 :test) => true or false
|
||||
;;; Return true if every element of l1 is an element of l2
|
||||
;;; and vice versa.
|
||||
|
||||
(defun set-equal (l1 l2 &key (test #'equal))
|
||||
(and (listp l1)
|
||||
(listp l2)
|
||||
(subsetp l1 l2 :test test)
|
||||
(subsetp l2 l1 :test test)))
|
||||
|
||||
|
||||
(provide "lisp-unit")
|
||||
|
|
@ -0,0 +1,128 @@
|
|||
(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")
|
||||
|#
|
||||
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
;;;; -*- Mode: Lisp; -*-
|
||||
|
||||
(defpackage #:z3950
|
||||
(:documentation "XXX")
|
||||
(:use #:common-lisp #:cffi #:lisp-unit)
|
||||
(:export #:connnection #:connection-error #:connect #:disconnect
|
||||
#:with-open-connection #:connection-host
|
||||
#:result-set #:result-set-size #:result-set-record
|
||||
#:search-pqf #:search-cql))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
;;;; -*- Mode: Lisp; -*-
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(eval-when (:load-toplevel :execute)
|
||||
(asdf:operate 'asdf:load-op '#:cffi-grovel))
|
||||
|
||||
#+cffi-features:darwin
|
||||
(push #p"/opt/local/lib/" cffi:*foreign-library-directories*)
|
||||
|
||||
(asdf:defsystem #:z3950
|
||||
:description "XXX"
|
||||
:perform (asdf:load-op :after (op z3950)
|
||||
(pushnew :z3950 *features*))
|
||||
:components ((:file "package" :depends-on ("lisp-unit"))
|
||||
(:file "libyaz" :depends-on ("grovel-yaz" "package"))
|
||||
(:file "lisp-unit")
|
||||
(:file "enc-marc-8" :depends-on ("package" "lisp-unit"))
|
||||
(:file "marc" :depends-on ("package"))
|
||||
(cffi-grovel:grovel-file "grovel-yaz" :depends-on ("package")))
|
||||
:depends-on (#:cffi #:trivial-garbage #:alexandria))
|
||||
|
||||
Reference in New Issue