Changeset 22567 for lang/gauche

Timestamp:

11/02/08 17:14:43 (5 years ago)

Author:

kiyoka

Message:

Supported 'Related pages:' feature.

Location:

lang/gauche/oldtype/trunk

Files:

• Kahua/oldtype/oldtype/core.scm (modified) (2 diffs)
• Kahua/oldtype/oldtype/format.scm (modified) (2 diffs)
• Kahua/oldtype/oldtype/oldtype.kahua (modified) (4 diffs)
• Kahua/oldtype/oldtype/page.scm (modified) (6 diffs)
• Kahua/oldtype/oldtype/util.kahua (modified) (1 diff)
• Kahua/oldtype/oldtype/version.kahua (modified) (1 diff)
• bin/convert.sh (modified) (3 diffs)
• command/blog (modified) (1 diff)
• command/genref (added)
• src/Makefile (modified) (1 diff)
• src/Test.no-timeline.sexp.master (modified) (1 diff)
• src/Test.sexp.master (modified) (1 diff)
• src/oldtype_to (modified) (1 diff)

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

@@ -36 +36 @@
   (export 
    oldtype:load-page
+   oldtype:load-command-list
    ))
 (select-module oldtype.core)
@@ -63 +64 @@
 
 
+(define (oldtype:load-command-list _site-root)
+  (define (gen-sexp-filename1)
+    (string-append _site-root "/tmp/oldtype/_out/__commands.sexp"))
+  (define (gen-sexp-filename2)
+    (string-append "./__commands.sexp"))
+  (let1 filename (cond
+                  ((file-exists? (gen-sexp-filename1))
+                   (gen-sexp-filename1))
+                  ((file-exists? (gen-sexp-filename2))
+                   (gen-sexp-filename2))
+                  (else
+                   #f))
+        (if filename
+            (with-input-from-file filename
+              (lambda ()
+                (apply
+                 append
+                 (read (current-input-port)))))
+            #f)))
+
+
 (provide "oldtype/core")

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

@@ -150 +150 @@
 ;; SXML to wiki-command list in the page.
 ;;
-(define (oldtype:sxml->command-list sxmls)
+;;  data format is :
+;;    '(
+;;       ("string")                  ;; means [[string]] wiki name
+;;       (reference "B" "A")         ;; means `page A has reference to page B.' ( A->B )
+;;       (command arg1 arg2...)      ;; means ##(command arg1 arg2...)
+;;        .
+;;        .
+;;     )
+;;
+(define (oldtype:sxml->command-list sxmls wikiname)
   (let1 commands '()
         (let rec
@@ -172 +181 @@
                             (push! commands arg))
                            ((wiki-name)
+                            (if (string? (car arg))
+                                (if (not (#/[|]/ (car arg)))
+                                    (push! commands (list 'reference (car arg) wikiname))))
                             (push! commands arg))
                            (else

lang/gauche/oldtype/trunk/Kahua/oldtype/oldtype/oldtype.kahua

@@ -113 +113 @@
                 (get-text-list oldtype-page)))))
             ""
+            '() ;; command-list
             lineno
             ))))
@@ -275 +276 @@
 
 
-(define (standard-page wikiname barcode nodes first-line . rest-arg)
+(define (standard-page wikiname barcode nodes first-line command-list . rest-arg)
   (html/ (head/ (title/ (string-append wikiname " / " first-line))
                 (link/ (@/ (rel "stylesheet") (type "text/css")
@@ -334 +335 @@
                    (oldtype:icon-image 'plain))
                (oldtype:hatena-bookmarks wikiname))
+          (text/ "Related pages:")(oldtype:reference-pages/ wikiname command-list)
+          (br/)
           barcode
           (hr/)
@@ -357 +360 @@
 
 (define (show-page/page wikiname)
-  (let1 oldtype-page (oldtype:load-page (kahua-site-root) wikiname)
-        (standard-page
-         wikiname
-         (if oldtype-page
-             (oldtype-page->barcode oldtype-page)
-             (br/))
-         (if oldtype-page
-             (oldtype-page->higher-order-tag oldtype-page)
-             (div/
-              (p/
-               (@/ (class "center"))
-               (strong/
-                (@/ (class "caption"))
-                "This wikipage was not found."))))
-         (if oldtype-page
-             (oldtype-first-line oldtype-page)
-             ""))))
+  (let ((oldtype-page (oldtype:load-page (kahua-site-root) wikiname))
+        (command-list (oldtype:load-command-list (kahua-site-root))))
+    (standard-page
+     wikiname
+     (if oldtype-page
+         (oldtype-page->barcode oldtype-page)
+         (br/))
+     (if oldtype-page
+         (oldtype-page->higher-order-tag oldtype-page)
+         (div/
+          (p/
+           (@/ (class "center"))
+           (strong/
+            (@/ (class "caption"))
+            "This wikipage was not found."))))
+     (if oldtype-page
+         (oldtype-first-line oldtype-page)
+         "")
+     command-list)))
 
 

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

@@ -60 +60 @@
           get-plain-list
           get-rich-list
+          get-command-list
           get-rss-entry-pages
           ))
@@ -82 +83 @@
    ;; vector of rich text in page
    (rich        :accessor rich-of        :init-keyword :rich
+                :init-value '())
+   ;; list of commands in page
+   (commands    :accessor commands-of    :init-keyword :commands
                 :init-value '())
    ))
@@ -109 +113 @@
           (oldtype:sxml->plain-text (sxml-of self) #t)
           #\newline)))
+  (set! (commands-of self)
+        (oldtype:sxml->command-list (sxml-of self) (name-of self)))
   self)
 
@@ -118 +124 @@
     (timeline . ,(serialize (timeline-of self)))
     (plain    . ,(vector->list (plain-of self)))
-    (rich     . ,(vector->list (rich-of self)))))
+    (rich     . ,(vector->list (rich-of self)))
+    (commands . ,(commands-of self))))
 
 
@@ -127 +134 @@
     :timeline  (deserialize (make <oldtype-timeline>) (assq-ref internal-data 'timeline))
     :plain     (list->vector (assq-ref internal-data 'plain))
-    :rich      (list->vector (assq-ref internal-data 'rich))))
+    :rich      (list->vector (assq-ref internal-data 'rich))
+    :commands  (assq-ref internal-data 'commands)))
 
 
@@ -162 +170 @@
 (define-method get-rich-list ((self <oldtype-page>))
   (vector->list (rich-of self)))
+
+(define-method get-command-list ((self <oldtype-page>))
+  (commands-of self))
 
 

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

@@ -471 +471 @@
              (img/ (@/ (src "http://d.hatena.ne.jp/images/b_entry_de.gif"))))
          (img/ (@/ (src (string-append "http://b.hatena.ne.jp/entry/image/http://" (oldtype:get-arguments 'fqdn) path)))))))
+
+
+(define (oldtype:reference-pages/ wikiname command-list)
+  (let1 ret 
+        (map/
+         (lambda (name)
+           (node-set/
+            (text/ " ")
+            (a/ (@/ (href name))
+                name)))
+         (reverse
+          (sort
+           (delete-duplicates
+            (filter-map
+             (lambda (x)
+               (if (eq? 'reference (car x))
+                   (let ((from (caddr x))
+                         (to   (cadr x)))
+                     (if (and (string=? wikiname to)
+                              (not (string=? from wikiname))
+                              (not (string=? from "!RecentChanges"))
+                              (not (string=? from "!AllPages")))
+                         from
+                         #f))
+                   #f))
+             command-list)))))
+        (if (null? ret)
+            (text/ "")
+            ret)))
+       
+       
+
+

lang/gauche/oldtype/trunk/Kahua/oldtype/oldtype/version.kahua

@@ -7 +7 @@
 
 ;;---------------------------------------------------------
-(define *oldtype-version* "0.3.6")
+(define *oldtype-version* "0.3.7")

lang/gauche/oldtype/trunk/bin/convert.sh

@@ -6 +6 @@
 
 _oldtype_to() {
-    t=$1
-    src=$2
-    dst=$3
-    log=$4
-    ann=$5
-    ${OT_HOME}/src/oldtype_to ${t} ${src} ${log} ${ann} > ../_out/${base}.sexp.tmp
+    src=$1
+    log=$2
+    ann=$3
+    ${OT_HOME}/src/oldtype_to internal ${src} ${log} ${ann} > ../_out/${base}.sexp.tmp
+    ${OT_HOME}/src/oldtype_to commands ${src} ${log} ${ann} > ../_out/${base}.commands
 
     if [ "$?" = "0" ] ; then
@@ -42 +41 @@
   base=`basename ${f} .ot`
   echo "[" ${base} "]"
-  _oldtype_to internal "${base}.ot" ../_out/${base}.sexp
+  _oldtype_to "${base}.ot"
 done
 
@@ -74 +73 @@
           logger "OldType: ${msg}"
       fi
-      _oldtype_to internal "${base}.ot" ../_out/${base}.sexp     ../_tmp/tmp.log ../_tmp/tmp.ann
+      _oldtype_to "${base}.ot"   ../_tmp/tmp.log ../_tmp/tmp.ann
   fi
 done
 
+# create _commands.sexp
+echo "(" > ../_out/__commands.sexp
+cat ../_out/*.commands >> ../_out/__commands.sexp
+echo ")" >> ../_out/__commands.sexp
+
 popd

lang/gauche/oldtype/trunk/command/blog

@@ -1 +1 @@
 #!/usr/local/bin/gosh
+;;;
+;;; blog - generating blog aggregate page.
+;;;
+;;;  Copyright (c) 2008 Kiyoka Nishiyama, All rights reserved.
+;;;
+;;;  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.
 
 (use srfi-1)

lang/gauche/oldtype/trunk/src/Makefile

@@ -32 +32 @@
         svn ann ../edit/Entry2.ot  > Entry2.ann.txt
 
+reftest:
+        gosh -I ../Kahua/oldtype ../command/genref /Users/kiyoka/work/site-unstable
 
 svninfo:

lang/gauche/oldtype/trunk/src/Test.no-timeline.sexp.master

@@ -27 +27 @@
   (distribution))
  (plain "* UnitTest用のサンプルファイル" "----" "*** start" "*** Entry1" "*** Entry2" "*** end" "")
- (rich "<h2>UnitTest用のサンプルファイル" "</h2><hr><h4>start" "</h4><h4>Entry1" "</h4><h4>Entry2" "</h4><h4>end" "</h4>"))
+ (rich "<h2>UnitTest用のサンプルファイル" "</h2><hr><h4>start" "</h4><h4>Entry1" "</h4><h4>Entry2" "</h4><h4>end" "</h4>")
+ (commands
+  (reference "Entry1" "Test")
+  ("Entry1")
+  (reference "Entry2" "Test")
+  ("Entry2")))

lang/gauche/oldtype/trunk/src/Test.sexp.master

@@ -100 +100 @@
    (13304 2)))
  (plain "* UnitTest用のサンプルファイル" "----" "*** start" "*** Entry1" "*** Entry2" "*** end" "")
- (rich "<h2>UnitTest用のサンプルファイル" "</h2><hr><h4>start" "</h4><h4>Entry1" "</h4><h4>Entry2" "</h4><h4>end" "</h4>"))
+ (rich "<h2>UnitTest用のサンプルファイル" "</h2><hr><h4>start" "</h4><h4>Entry1" "</h4><h4>Entry2" "</h4><h4>end" "</h4>")
+ (commands
+  (reference "Entry1" "Test")
+  ("Entry1")
+  (reference "Entry2" "Test")
+  ("Entry2")))

lang/gauche/oldtype/trunk/src/oldtype_to

@@ -175 +175 @@
        (let* (
               (sxml           (oldtype-parse input-port))
-              (sexp           (oldtype:sxml->command-list sxml)))
+              (sexp           (oldtype:sxml->command-list sxml wikiname)))
          (pretty-print-sexp sexp)))
       (else