root/lang/gauche/oldtype/trunk/Kahua/oldtype/oldtype/util.scm @ 28220

Revision 28220, 11.1 kB (checked in by kiyoka, 6 years ago)

Added oldtype:rss-limit.

Line 
1;;;
2;;; oldtype/util.scm - util for OldType
3;;;
4;;;  Copyright (c) 2008 Kiyoka Nishiyama, All rights reserved.
5;;;
6;;;  Permission is hereby granted, free of charge, to any person
7;;;  obtaining a copy of this software and associated documentation
8;;;  files (the "Software"), to deal in the Software without restriction,
9;;;  including without limitation the rights to use, copy, modify,
10;;;  merge, publish, distribute, sublicense, and/or sell copies of
11;;;  the Software, and to permit persons to whom the Software is
12;;;  furnished to do so, subject to the following conditions:
13;;;
14;;;  The above copyright notice and this permission notice shall be
15;;;  included in all copies or substantial portions of the Software.
16;;;
17;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
18;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
19;;;  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
20;;;  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
21;;;  BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
22;;;  AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
23;;;  OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
24;;;  IN THE SOFTWARE.
25;;;
26;;; $Id: util.scm 199 2008-01-13 11:16:43Z kiyoka $
27;;;
28
29(define-module oldtype.util
30  (use srfi-1)
31  (use srfi-13)
32  (use srfi-19)
33  (use sxml.ssax)
34  (use sxml.sxpath)
35  (use text.parse)
36  (use file.util)
37  (use util.list)
38  (use oldtype.pasttime)
39  (export oldtype:otpath->wikiname
40          oldtype:otpath->basename
41          oldtype:version
42          oldtype:site-url
43          oldtype:rank-limit
44          oldtype:rss-limit
45          oldtype:image-height-s
46          oldtype:image-height-m
47          oldtype:get-string-of-today
48          oldtype:editpath
49          oldtype:workpath
50          oldtype:user-local
51          oldtype:user-backend
52          oldtype:get-pagelist
53          oldtype:parse-svninfo
54          oldtype:date-string->date-alist
55          oldtype:utc->date-string
56          oldtype:utc->RFC822-date-string
57          oldtype:utc->ago-string
58          oldtype:grouping-blog-entries
59          oldtype:thumbnail-filter
60          oldtype:amazon-link
61          oldtype:amazon-thumbnail
62          oldtype:youtube-link
63          oldtype:youtube-thumbnail
64          pretty-print-sexp))
65(select-module oldtype.util)
66
67(load "oldtype/version.kahua")
68
69
70;;=================================================
71;; Const values for OldType
72;;
73(define oldtype:version  *oldtype-version*)
74(define oldtype:site-url "http://sourceforge.jp/projects/oldtype/")
75(define oldtype:rank-limit 5)
76(define oldtype:rss-limit 30)
77(define oldtype:image-height-s 40)
78(define oldtype:image-height-m 80)
79
80
81;;=================================================
82;; Utility for OldType
83;;
84(define (oldtype:otpath->basename filepath)
85  (receive (path basename suffix)
86      (decompose-path filepath)
87    basename))
88
89(define (oldtype:otpath->wikiname filepath)
90  (oldtype:otpath->basename filepath))
91
92(define (oldtype:get-string-of-today)
93  (date->string (current-date) "~Y_~m_~d"))
94
95(define (oldtype:editpath)
96  (string-append
97   (sys-getenv "OT_SITE")
98   "/tmp/oldtype/edit"))
99
100(define (oldtype:workpath)
101  (string-append
102   (sys-getenv "OT_SITE")
103   "/tmp/work"))
104
105(define (oldtype:user-local)
106  (sys-getenv "OT_USER_LOCAL"))
107
108(define (oldtype:user-backend)
109  (sys-getenv "OT_USER_BACKEND"))
110
111
112;;=================================================
113;; for Batch process
114;;
115
116(define (oldtype:get-pagelist regexp-string)
117  (reverse
118   (directory-list (oldtype:editpath)
119                   :filter (lambda (filename)
120                             (if regexp-string
121                                 ((string->regexp regexp-string) filename)
122                                 #t)))))
123
124;;=================================================
125;; for date string
126;;
127;;
128;; str:
129;;   "2007-09-25T12:54:09.955196Z"
130;; result:
131;;   ((nanosecond . 0) (second . 9) (minute . 54) (hour . 12) (day . 25) (month . 9) (year . 2007) (zone-offset . 0) (utc . 1190724849))
132;;   
133(define (oldtype:date-string->date-alist str)
134  (let* ((splitted (map string->number (string-split str #/[TZ.\-:]/)))
135         (date-object
136          (make-date 0;; nanosecond
137                     (sixth  splitted) ;;second
138                     (fifth  splitted) ;;minute
139                     (fourth splitted) ;;hour
140                     (third  splitted) ;;day
141                     (second splitted) ;;month
142                     (first  splitted) ;;year
143                     0 ;;zone-offset
144                     )))
145    `(
146      (nanosecond  . ,(date-nanosecond date-object))
147      (second      . ,(date-second date-object))
148      (minute      . ,(date-minute date-object))
149      (hour        . ,(date-hour date-object))
150      (day         . ,(date-day date-object))
151      (month       . ,(date-month date-object))
152      (year        . ,(date-year date-object))
153      (zone-offset . ,(date-zone-offset date-object))
154      (utc         . ,(time->seconds (date->time-utc date-object))))))
155
156
157;;
158;; result format:
159;;  (
160;;   ( ;; file1
161;;    (name . "OldType")
162;;    (commit_revision . "100")
163;;    (commit_auther   . "user01")
164;;    (date . "2007-09-24T14:18:01.076277Z")
165;;       .
166;;       .
167;;       .
168;;   )
169;;   ( ;; file2
170;;    (name . "OldType2")
171;;    (commit_revision . "120")
172;;    (commit_auther   . "user02")
173;;    (date . "2007-09-24T14:18:01.076277Z")
174;;   )
175;;  )
176(define (oldtype:parse-svninfo port)
177  (define (date-string-as-current-locale str)
178    (let* ((date-str (string-append (car (string-split str ".")) " +0000"))
179           (utc      (date->time-utc (string->date date-str "~Y-~m-~dT~H:~M:~S ~z"))))
180      (date->string (time-utc->date utc)
181                    "~Y-~m-~d ~I:~M ~p (~z)")))
182  (define (utc-as-current-locale str)
183    (number->string
184     (time->seconds
185      (date->time-utc
186       (string->date
187        (string-append (car (string-split str ".")) " +0000")
188        "~Y-~m-~dT~H:~M:~S ~z")))))
189  (let1 sxml
190        (ssax:xml->sxml port '())
191        (map
192         (lambda (x)
193           `(
194             (name               . ,(oldtype:otpath->wikiname (second x)))
195             (kind               . ,(first x))
196             (path               . ,(second x))
197             (revision           . ,(third x))
198             (commit_revision    . ,(fourth x))
199             (commit_author      . ,(fifth x))
200             (commit_date        . ,(date-string-as-current-locale
201                                     (sixth x)))
202             (commit_utc         . ,(utc-as-current-locale
203                                     (sixth x)))
204             ))
205         (zip
206          ((sxpath "//info/entry/@kind/text()") sxml)
207          ((sxpath "//info/entry/@path/text()") sxml)
208          ((sxpath "//info/entry/@revision/text()") sxml)
209          ((sxpath "//info/entry/commit/@revision/text()") sxml)
210          ((sxpath "//info/entry/commit/author/text()") sxml)
211          ((sxpath "//info/entry/commit/date/text()") sxml)
212          ))))
213
214;;
215;; imported from this URL ( written by bizen )
216;;    http://practical-scheme.net/wiliki/wiliki.cgi?Gauche%3APrettyPrint
217;;
218(define (pretty-print-sexp s)
219  (define (do-indent level)
220    (dotimes (_ level) (write-char #\space)))
221  (define (pp-parenl)
222    (write-char #\())
223  (define (pp-parenr)
224    (write-char #\)))
225  (define (pp-atom e prefix)
226    (when prefix (write-char #\space))
227    (write e))
228  (define (pp-list s level prefix)
229    (and prefix (do-indent level))
230    (pp-parenl)
231    (let loop ((s s)
232               (prefix #f))
233      (if (null? s)
234          (pp-parenr)
235          (let1 e (car s)
236            (if (list? e)
237                (begin (and prefix (newline))
238                       (pp-list e (+ level 1) prefix))
239                (pp-atom e prefix))
240            (loop (cdr s) #t)))))
241  (if (list? s)
242      (pp-list s 0 #f)
243      (write s))
244  (newline))
245
246
247;;
248;; Convert utc seconds to "2008-03-20 09:36 PM (+0900)"
249;;
250(define (oldtype:utc->date-string utc)
251  (if utc
252      (let1 d (time-utc->date
253               (seconds->time
254                utc))
255            (string-append (date->string d "~Y-~m-~d ~H:~M (~z)")))
256      "*NoDateInformation*"))
257
258;;
259;; Convert utc seconds to RFC822 like "20 Mar 2008 18:36:00 +0000"
260;;
261(define (oldtype:utc->RFC822-date-string utc)
262  (sys-strftime "%d %b %Y %H:%M:%S +0000" (sys-gmtime utc)))
263
264;;
265;; Convert utc seconds to "    (10 seconds ago)"
266;;
267(define (oldtype:utc->ago-string utc)
268  (if utc
269      (string-append
270       (format "~16,,,' @a"
271               (string-append
272                "("
273                (how-long-since utc)
274                " ago)")))
275      "*NoDateInformation*"))
276
277;;
278;; grouping blog entry list by month
279;;
280;; arg:
281;;   ("kiyoka.2008_10_01.ot" "kiyoka.2008_10_03.ot" ...)
282;;
283;; result:
284;;   (
285;;     (YEAR_MONTH LIST-OF-ENTRY)
286;;     (2008_10 ("kiyoka.2008_10_01.ot" "kiyoka.2008_10_03.ot" ...))
287;;     (2008_11 ("kiyoka.2008_11_02.ot" "kiyoka.2008_11_03.ot" ...))
288;;   )
289;;
290(define (oldtype:grouping-blog-entries entrylist)
291  (define (check-format str)
292    (#/^[^.]+[.][0-9]+_[0-9]+_[0-9]+/ str))
293
294  (let ((valid-entries
295         (reverse
296          (sort
297           (filter
298            (lambda (name)
299              (check-format name))
300            entrylist))))
301        (ht (make-hash-table 'string=?)))
302    (for-each
303     (lambda (name)
304       (let* ((lst (string-split name #/[._]/))
305              (str (string-append (second lst)  ;; year
306                                  "_"
307                                  (third  lst)) ;; month
308                   ))
309         (hash-table-push! ht
310                           str
311                           name)))
312     valid-entries)
313    (hash-table->alist ht)))
314
315
316;;
317;; test pattern:
318;;   (thumbnail-filter '("line 1"
319;;                       "line 2"
320;;                       "line 3"
321;;                       "line 4"
322;;                       "##(amazon 4873113482)       ##(img-s ../img/abc.jpg)"
323;;                       "! ##(youtube 4873113482)    ##(img-m ../img/abc.jpg)"
324;;                       ))
325;; result:
326;;  "##(img-s ../img/abc.jpg)  ##(amazon-s 4873113482) "
327;;
328(define (oldtype:thumbnail-filter str-list)
329  (let1 ret '()
330        (for-each
331         (lambda (line)
332           (when (not (#/^[!]/ line))
333             (regexp-replace-all
334              #/##\((img|img-s|img-m|youtube|youtube-s|youtube-m|amazon|amazon-s|amazon-m)[ ]+([^\)]+)\)/
335              line
336              (lambda (m)
337                (push! ret (list
338                            (rxmatch-substring m 1)
339                            (rxmatch-substring m 2)))))))
340         str-list)
341        (string-join
342         (map
343          (lambda (x)
344            (let1 command-pair (string-split (car x) #\-)
345                  (string-append
346                   "##(" (car command-pair) "-s " (cadr x) ") ")))
347          (reverse ret)))))
348
349
350(define (oldtype:amazon-link asin-code)
351  (format #f "http://amazon.co.jp/o/ASIN/~a/kiye-22/ref=nosim" asin-code))
352
353(define (oldtype:amazon-thumbnail asin-code)
354  (format #f "http://images.amazon.com/images/P/~a.09.MZZZZZZZ_.jpg" asin-code))
355
356(define (oldtype:youtube-link video-id)
357  (format #f "http://www.youtube.com/v/~a" video-id))
358
359(define (oldtype:youtube-thumbnail video-id)
360  (format #f "http://img.youtube.com/vi/~a/1.jpg" video-id))
361                                   
362
363(provide "oldtype/util")
Note: See TracBrowser for help on using the browser.