Context Navigation

← Previous Changeset
Next Changeset →

Changeset 12266

Timestamp:

05/24/08 13:01:28 (5 years ago)

Author:

kiyoka

Message:

Supported serialize and deserialize internal data by <oldtype-page> type.

Location:

lang/gauche/oldtype/trunk

Files:

: 1 added
: 7 modified

Kahua/oldtype/oldtype/format.scm (modified) (2 diffs)
Kahua/oldtype/oldtype/page.scm (added)
Kahua/oldtype/oldtype/rss.scm (modified) (4 diffs)
Kahua/oldtype/oldtype/timeline.scm (modified) (9 diffs)
Kahua/oldtype/oldtype/util.scm (modified) (2 diffs)
src/Makefile (modified) (2 diffs)
src/oldtype_to (modified) (2 diffs)
src/test.scm (modified) (1 diff)

Legend:

: Unmodified
: Added
: Removed

lang/gauche/oldtype/trunk/Kahua/oldtype/oldtype/format.scm

r8676	r12266
145	145	;;
146	146	;; [intenal format is SXML like]
147		;; '(
148		;; (top
149		;; '((420 ( (user . "user") (date <date>) ))
150		;; (313 ( (user . "user") (date <date>) ))
151		;; (234 ( (user . "user") (date <date>) ))
152		;; ( 51 ( (user . "user") (date <date>) ))
153		;; ( 20 ( (user . "user") (date <date>) ))))
154		;; (sxml
155		;; ((div
156		;; ( (orig . "ORIGINAL WIKI STRING")
157		;; (committer . SYMBOL_OF_COMMIT_USER)
158		;; (lineno . LINENO)
159		;; (latest-rate . NUMBER)
160		;; (rev . COMMIT_REVISION_NUMBER)
161		;; (commit-utc . COMMIT_UTC_SECONDS)
162		;; )
163		;; (TAG
164		;; "string" "string" "string"
165		;; (wiki-macro MACRONAME args)
166		;; (wiki-name WIKINAME)
167		;; (TAG ..... )
168		;; )
	147	;; (
	148	;; (div
	149	;; ((lineno . LINENO))
	150	;; (TAG
	151	;; "string" "string" "string"
	152	;; (wiki-macro MACRONAME args)
	153	;; (wiki-name WIKINAME)
	154	;; (TAG ..... )
169	155	;; )
170		;; ~~(div~~
171		;; .
172		;; .
173		;; )
174		;; ))
	156	;; )
	157	;; (div
	158	;; .
	159	;; .
	160	;; )
175	161	;; )
176	162	;;
…	…
178	164	;;
179	165	;;
180		(define (oldtype:sxml->internal sxmls log ann original-src)
181		(define (get-top-revisions log ann)
182		(if ann
183		(top-revisions log ann)
184		'()))
185		(define (sxml->internal sxml top)
186		(let rec
187		((sxmls sxmls)
188		(hctx '())) ;;headings context
189		(match sxmls
190		(() '())
191		((('wiki-macro . expr) . rest)
192		(cons `(wiki-macro ,@expr)
193		(rec rest hctx)))
194		(((and (name . _) sxml) . rest) ;; generic node
195		(let* ((lineno (assq 'lineno (sxml:aux-list-u sxml)))
196		(ann-of-line (if (and lineno ann (get-ann-by-lineno ann (second lineno)))
197		(get-ann-by-lineno ann (second lineno))
198		#f))
199		(line-alist (if ann-of-line
200		(car (assq-ref
201		top
202		(car ann-of-line)))
203		'((index . 5))))
204		(rev (if ann-of-line
205		(car ann-of-line)
206		#f))
207		(info-of-line (if rev
208		(assq-ref top rev)
209		#f))
210		(commit-utc (if info-of-line
211		(assq-ref (assq-ref (car info-of-line) 'date) 'utc)
212		0))
213		(latest-rate (assq-ref line-alist 'index)))
214
215		(let1 _
216		`(,name ,@(cond ((sxml:attr-list-node sxml) => list)
217		(else '()))
218		,@(rec (sxml:content sxml) hctx))
219		(cons
220		(case name
221		((div)
222		`(div
223		(,(if lineno
224		`(lineno . ,(second lineno))
225		`())
226		(latest-rate . ,latest-rate)
227		(orig . ,(if ann-of-line
228		(assq-ref (cadr ann-of-line) 'str)
229		""))
230		(committer . ,(if ann-of-line
231		(assq-ref (cadr ann-of-line) 'user)
232		'oldtype))
233		(rev . ,rev)
234		(commit-utc . ,commit-utc)
235		)
236		,@(rec (sxml:content sxml) hctx)))
237		((a)
238		(let ((param (cadr sxml))
239		(_rest (cddr sxml)))
240		`(a
241		,param
242		,@(rec _rest hctx))))
243		(else
244		_))
245		(rec rest hctx)))))
246		((other . rest)
247		(cons other (rec rest hctx))))))
248
249		(let ((top (get-top-revisions log ann)))
250		`(
251		(sxml ,(sxml->internal sxmls top))
252		(top ,top)
253		(src ,(port->string-list
254		(open-input-string original-src))))))
	166	(define (oldtype:sxml->internal sxmls)
	167	(let rec
	168	((sxmls sxmls)
	169	(hctx '())) ;;headings context
	170	(match sxmls
	171	(() '())
	172	((('wiki-macro . expr) . rest)
	173	(cons `(wiki-macro ,@expr)
	174	(rec rest hctx)))
	175	(((and (name . _) sxml) . rest) ;; generic node
	176	(let* ((lineno (assq 'lineno (sxml:aux-list-u sxml))))
	177	(let1 _
	178	`(,name ,@(cond ((sxml:attr-list-node sxml) => list)
	179	(else '()))
	180	,@(rec (sxml:content sxml) hctx))
	181	(cons
	182	(case name
	183	((div)
	184	`(div
	185	(,(if lineno
	186	`(lineno . ,(second lineno))
	187	`()))
	188	,@(rec (sxml:content sxml) hctx)))
	189	((a)
	190	(let ((param (cadr sxml))
	191	(_rest (cddr sxml)))
	192	`(a
	193	,param
	194	,@(rec _rest hctx))))
	195	(else
	196	_))
	197	(rec rest hctx)))))
	198	((other . rest)
	199	(cons other (rec rest hctx))))))
	200
255	201
256	202	;;

lang/gauche/oldtype/trunk/Kahua/oldtype/oldtype/rss.scm

r11245	r12266
1	1	;;;
2		;;; ~~wiliki~~/rss - an ad-hoc RSS generation routine for WiLiKi
	2	;;; oldtype/rss - an ad-hoc RSS generation routine for WiLiKi
3	3	;;;
4	4	;;; Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
…	…
24	24	;;; IN THE SOFTWARE.
25	25	;;;
26		;;; $Id: ~~rss.scm,v 1.9 2007-05-02 13:02:44 shirok Exp~~ $
	26	;;; $Id: $
27	27	;;;
	28	;;;
	29	;;; Modified by kiyoka to implement OldType rss generator.
	30	;;; I renamed namespace of wiliki- 'oldtype-' to avoid collision of
	31	;;; installation.
28	32
29	33	;; In future, this might be rewritten to use proper XML framework.
30	34	;; for now, I use an ad-hoc approach.
31	35
32		(define-module wiliki.rss
33		(use wiliki.db)
	36	(define-module oldtype.rss
34	37	(use util.list)
35	38	(use text.html-lite)
36		(extend wiliki)
37		(export rss-page))
38		(select-module wiliki.rss)
	39	(extend oldtype))
	40	(select-module oldtype.rss)
39	41
40		;; API
41		(define (rss-page)
42		(rss-format (take* (wiliki-db-recent-changes) 15)))
43
44		(define (rss-format entries)
45		(let* ((self (wiliki))
46		(full-url (full-script-path-of self)))
	42	;;
	43	;; generate RSS content.
	44	;;
	45	;; header:
	46	;; (
	47	;; (url . TITLE-OF-RSS)
	48	;; (title . TITLE-OF-RSS)
	49	;; (desc . DESCRIPTION-OF-RSS)
	50	;; )
	51	;; entries:
	52	;; (
	53	;; ;; entry No.1
	54	;; (
	55	;; (url . FULL-URL)
	56	;; (utc . GENERATE-DATE)
	57	;; (title . TITLE)
	58	;; )
	59	;; ;; entry No.2
	60	;; .
	61	;; .
	62	;; .
	63	;; )
	64	;;
	65	(define (rss-format header entries)
	66	(let* (
	67	(title (assq-ref header 'title))
	68	(url (assq-ref header 'url)))
47	69	`("Content-type: text/xml\n\n"
48		"<?xml version=\"1.0\" encoding=\"~~" ,(output-charset) "~~\" ?>\n"
	70	"<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
49	71	"<rdf:RDF
50	72	xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"
…	…
53	75	>\n"
54	76	,(rdf-channel
55		~~full-~~url
56		(rdf-title ~~(title-of self)~~)
57		(rdf-link ~~full-~~url)
58		(rdf-description ~~(description-of self)~~)
	77	url
	78	(rdf-title title)
	79	(rdf-link url)
	80	(rdf-description desc)
59	81	(rdf-items-seq
60		(map (lambda (entry) (rdf-li (~~url-full "~a" (cv-out (car entry)))~~))
61		entries)))
	82	(map (lambda (entry) (rdf-li (assq-ref entry 'title))
	83	entries))))
62	84	,(map (lambda (entry)
63		(let1 url (~~url-full "~a" (cv-out (car entry))~~)
64		(rdf-item url
65		~~(rdf-title (car entry~~))
66		(rdf-link url)
67		~~(dc-date (cdr entry~~)))))
	85	(let1 url (assq-ref entry 'url)
	86	(rdf-item url
	87	(rdf-title (assq-ref entry 'url))
	88	(rdf-link url)
	89	(dc-date (assq-ref entry 'utc)))))
68	90	entries)
69	91	"</rdf:RDF>\n")))
…	…
99	121	(sys-strftime "%Y-%m-%dT%H:%M:%S+00:00" (sys-gmtime secs))))
100	122
101		(provide "~~wiliki~~/rss")
	123	(provide "oldtype/rss")

lang/gauche/oldtype/trunk/Kahua/oldtype/oldtype/timeline.scm

r11606	r12266
40	40	(use oldtype.util)
41	41	(export <oldtype-timeline>
42		~~load~~
	42	parse
43	43	serialize
44		~~oldtype-timeline:un~~serialize
	44	deserialize
45	45	))
46	46	(select-module oldtype.timeline)
…	…
53	53	;; committer
54	54	(committer :accessor committer-of :init-keyword :committer
55		:init-value "no~~body~~")
	55	:init-value "none")
56	56	;; utc
57	57	(utc :accessor utc-of :init-keyword :utc
…	…
59	59	))
60	60
61		;;
62		;; serialize <oldtype-log>
63		;;
	61
64	62	(define-method serialize ((self <oldtype-log>))
65	63	`((revision . ,(revision-of self))
…	…
68	66
69	67	;;
70		;; serialize <oldtype-log>
71		;;
72		(define-method ~~oldtype-log:unserialize (~~sexp)
	68	;; deserialize <oldtype-log>
	69	;;
	70	(define-method deserialize ((dummy <oldtype-log>) sexp)
73	71	(make <oldtype-log>
74	72	:revision (assq-ref sexp 'revision)
…	…
81	79	;; page name (utf-8)
82	80	(name :accessor name-of :init-keyword :name
83		:init-value "no~~body~~")
	81	:init-value "none")
84	82	;; latest revision no
85	83	(revision :accessor revision-of :init-keyword :revision
…	…
168	166
169	167	;;
170		;; ~~load~~ log-file and ann-file to <oldtype-timeline> object
171		;;
172		(define-method ~~load~~ ((self <oldtype-timeline>) log-file ann-file)
	168	;; parse log-file and ann-file to <oldtype-timeline> object
	169	;;
	170	(define-method parse ((self <oldtype-timeline>) log-file ann-file)
173	171	(let ((log (oldtype:parse-log log-file))
174	172	(ann (oldtype:parse-annotate ann-file)))
…	…
212	210	self))
213	211
214		;;
215		;; serialize <oldtype-timeline>
216		;;
	212
217	213	(define-method serialize ((self <oldtype-timeline>))
218	214	`((name . ,(name-of self))
…	…
225	221	(log-of self)))
226	222	(annotation . ,(map
227		(lambda (x)
228		(serialize x))
	223	serialize
229	224	(vector->list (annotation-of self))))
230	225	(text . ,(vector->list (text-of self)))))
231	226
232	227
	228
233	229	;;
234	230	;; serialize <oldtype-timeline>
235	231	;;
236		(define-method ~~oldtype-timeline:unserialize (~~sexp)
	232	(define-method deserialize ((dummy <oldtype-timeline>) sexp)
237	233	(make <oldtype-timeline>
238	234	:name (assq-ref sexp 'name)
…	…
242	238	(cons
243	239	(car x)
244		(~~oldtype-log:unserialize~~ (cdr x))))
	240	(deserialize (make <oldtype-log>) (cdr x))))
245	241	(assq-ref sexp 'log))
246	242	:annotation (list->vector
247	243	(map
248	244	(lambda (x)
249		(~~oldtype-log:unserialize~~ x))
	245	(deserialize (make <oldtype-log>) x))
250	246	(assq-ref sexp 'annotation)))
251	247	:text (list->vector
252	248	(assq-ref sexp 'text))))
253	249
	250
254	251	(provide "oldtype/timeline")

lang/gauche/oldtype/trunk/Kahua/oldtype/oldtype/util.scm

r11607	r12266
52	52	oldtype:parse-annotate
53	53	oldtype:parse-svninfo
54		oldtype:date-string->date-alist))
	54	oldtype:date-string->date-alist
	55	pretty-print-sexp))
55	56	(select-module oldtype.util)
56	57
…	…
192	193	))))
193	194
	195	;;
	196	;; imported from this URL ( written by bizen )
	197	;; http://practical-scheme.net/wiliki/wiliki.cgi?Gauche%3APrettyPrint
	198	;;
	199	(define (pretty-print-sexp s)
	200	(define (do-indent level)
	201	(dotimes (_ level) (write-char #\space)))
	202	(define (pp-parenl)
	203	(write-char #\())
	204	(define (pp-parenr)
	205	(write-char #\)))
	206	(define (pp-atom e prefix)
	207	(when prefix (write-char #\space))
	208	(write e))
	209	(define (pp-list s level prefix)
	210	(and prefix (do-indent level))
	211	(pp-parenl)
	212	(let loop ((s s)
	213	(prefix #f))
	214	(if (null? s)
	215	(pp-parenr)
	216	(let1 e (car s)
	217	(if (list? e)
	218	(begin (and prefix (newline))
	219	(pp-list e (+ level 1) prefix))
	220	(pp-atom e prefix))
	221	(loop (cdr s) #t)))))
	222	(if (list? s)
	223	(pp-list s 0 #f)
	224	(write s))
	225	(newline))
	226
	227
194	228	(provide "oldtype/util")

lang/gauche/oldtype/trunk/src/Makefile

r8211	r12266
8	8	gosh -I ../Kahua/oldtype ./oldtype_to plain ${OTSAMPLE} > out.txt
9	9
	10	test: log.txt ann.txt
	11	gosh -I ../Kahua/oldtype test.scm ${OTSAMPLE} log.txt ann.txt > test.log
	12
10	13	log.txt:
11	14	svn --xml log ../ > log.txt
…	…
14	17	svn ann ${OTSAMPLE} > ann.txt
15	18
16		~~test:~~
17		~~@cat ${OTSAMPLE} \| gosh -I ../lib test.scm~~
18	19
19	20	svninfo:

lang/gauche/oldtype/trunk/src/oldtype_to

r7811	r12266
38	38	(use oldtype.format)
39	39	(use oldtype.util)
40
	40	(use oldtype.page)
	41	(use oldtype.timeline)
41	42
42	43
…	…
141	142	(case type
142	143	('internal
143		(receive (log ann) (parse-log-and-annotate rest)
144		(let* (
145		(sxml (oldtype-parse input-port))
146		(internal-sexp (oldtype:sxml->internal sxml log ann converted-str)))
147		(if #f
148		(begin
149		(use slib)
150		(require 'pretty-print)
151		(pretty-print internal-sexp))
152		(begin
153		(write internal-sexp))))))
	144	(let1 oldtype-page (parse (make <oldtype-page>) input-port (car rest) (cadr rest))
	145	(pretty-print-sexp (serialize oldtype-page))))
154	146	('sxml
155	147	(let1 sxml (oldtype-parse input-port)
156		(~~write~~ sxml)))
	148	(pretty-print-sexp sxml)))
157	149	('html
158	150	(let* (

lang/gauche/oldtype/trunk/src/test.scm

r7811	r12266
1	1	;; -- coding: utf-8 --
2		~~(use oldtype.parse)~~
3		~~(use oldtype.format)~~
4	2	(use srfi-1)
5		~~(use slib)~~
6	3	(use sxml.tools)
7	4	(use sxml.serializer)
8	5	(use text.html-lite)
9	6	(use text.tree)
	7	(use gauche.charconv)
	8	(use oldtype.parse)
	9	(use oldtype.format)
	10	(use oldtype.util)
	11	(use oldtype.timeline)
	12	(use oldtype.page)
	13	(use slib)
10	14	(require 'pretty-print)
11
12		(define (test:sxml->html sxml)
13		(let1 html-body (srl:sxml->html sxml)
14		(tree->string
15		`(
16		,(html:html
17		(html:head
18		(html:meta :http-equiv "Content-Type" :content "text/html; charset=utf-8")
19		(html:meta :http-equiv "Content-Style-Type" :content "text/css")
20		(html:link :rel "stylesheet" :href "oldtype.css" :type "text/css")
21		(html:title "テストページ")
22		(html:body
23		html-body
24		)))))))
25
26		(let* (
27		(sxml (oldtype-parse (current-input-port)))
28		;; (expanded-sxml (oldtype:expand-page sxml))
29		;; (html (test:sxml->html expanded-sxml))
30		)
31		(pretty-print sxml))
	15	(use gauche.test)
32	16
33	17
	18	;; Main -------------------------------------------------------
	19	(define (main args)
	20	(let* (
	21	(_ (cdr args))
	22	(input-file (first _))
	23	(log-file (second _))
	24	(ann-file (third _))
	25	(converted-str
	26	(port->string
	27	(open-input-conversion-port
	28	(open-input-file input-file)
	29	"*JP")))
34	30
	31	;; Making string port from stdin/file
	32	;;
	33	(input-port
	34	(open-input-string converted-str)))
35	35
	36	(test-start "oldtype_to")
36	37
37
38
	38	(test-section "oldtype-timeline")
	39	(let1 oldtype-timeline
	40	(parse (make <oldtype-timeline>) log-file ann-file)
	41	(let* ((serialized (serialize oldtype-timeline))
	42	(deserialized (deserialize (make <oldtype-timeline>) serialized)))
	43	(test "serialized == DATA "
	44	'((name . "none") (revision . 8208)
	45	(log
	46	(8208 (revision . 8208) (committer . kiyoka) (utc . 1206016615))
	47	(8205 (revision . 8205) (committer . kiyoka) (utc . 1206012635))
	48	(8091 (revision . 8091) (committer . kiyoka) (utc . 1205842976))
	49	(7924 (revision . 7924) (committer . kiyoka) (utc . 1205421544))
	50	(7920 (revision . 7920) (committer . kiyoka) (utc . 1205419584))
	51	(7919 (revision . 7919) (committer . kiyoka) (utc . 1205418381))
	52	(7870 (revision . 7870) (committer . kiyoka) (utc . 1205336331))
	53	(7811 (revision . 7811) (committer . kiyoka) (utc . 1205239814)))
	54	(annotation
	55	((revision . 8208) (committer . kiyoka) (utc . 1206016615))
	56	((revision . 7811) (committer . kiyoka) (utc . 1205239814)))
	57	(text "* UnitTest用のサンプルファイル" ""))
	58	(lambda () (serialize deserialized)))
	59	(test "serialized == deserialized" serialized (lambda () (serialize deserialized)))))
39	60
	61	(test-section "oldtype-page")
	62	(let1 oldtype-page (parse (make <oldtype-page>) input-port log-file ann-file)
	63	(let1 serialized (serialize oldtype-page)
	64	(test "serialized == DATA "
	65	'((name . "none")
	66	(sxml
	67	(div
	68	((lineno . 1))
	69	(h2 "UnitTest用のサンプルファイル" "\n")))
	70	(timeline (name . "none") (revision . 8208)
	71	(log
	72	(8208 (revision . 8208) (committer . kiyoka) (utc . 1206016615))
	73	(8205 (revision . 8205) (committer . kiyoka) (utc . 1206012635))
	74	(8091 (revision . 8091) (committer . kiyoka) (utc . 1205842976))
	75	(7924 (revision . 7924) (committer . kiyoka) (utc . 1205421544))
	76	(7920 (revision . 7920) (committer . kiyoka) (utc . 1205419584))
	77	(7919 (revision . 7919) (committer . kiyoka) (utc . 1205418381))
	78	(7870 (revision . 7870) (committer . kiyoka) (utc . 1205336331))
	79	(7811 (revision . 7811) (committer . kiyoka) (utc . 1205239814)))
	80	(annotation
	81	((revision . 8208) (committer . kiyoka) (utc . 1206016615))
	82	((revision . 7811) (committer . kiyoka) (utc . 1205239814)))
	83	(text "* UnitTest用のサンプルファイル" "")))
	84	(lambda () (serialize oldtype-page)))
40	85
	86	(test "serialized == deserialized" serialized (lambda ()
	87	(serialize
	88	(deserialize
	89	(make <oldtype-page>)
	90	serialized))))))
	91	(test-end)
	92	))
41	93

Download in other formats: