Changeset 12662 in project


Ignore:
Timestamp:
11/30/08 23:55:59 (13 years ago)
Author:
azul
Message:

Logic to register list of definitions and redirect to them.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/3/svnwiki-chicken/trunk/svnwiki-chicken.scm

    r12658 r12662  
    44
    55(declare (export))
    6 (use svnwiki-extensions-support svn-post-commit-hooks orders format-modular srfi-40 html-stream stream-ext)
     6(use svnwiki-extensions-support svn-post-commit-hooks orders format-modular srfi-40 html-stream stream-ext embedded-test)
    77
    88(define *url-eggs*
     
    3232      stream-null)))
    3333
     34(define *db* #f)
     35
     36(define (db-run env query . params)
     37  (let-from-environment env (data)
     38    (unless *db*
     39      (let* ((db-path (svnwiki-make-pathname data "scheme-definitions" "db"))
     40             (existed (file-exists? db-path)))
     41        (format (current-error-port) "Opening DB: ~A~%" db-path)
     42        (set! *db* (sqlite3:open db-path))
     43        (unless existed
     44          (format (current-error-port) "Creating initial tables in DB: ~A~%" db-path)
     45          (scheme-definitions-db-create env))))
     46    (let ((result
     47            (iterator->stream
     48              (lambda (capture stop)
     49                (receive (stmt rest)
     50                         (sqlite3:prepare *db* query)
     51                  (apply (stream-wrap-proc-string sqlite3:for-each-row) (compose capture vector) stmt params)
     52                  (sqlite3:finalize! stmt))))))
     53      (stream-length result) ; force execution
     54      result)))
     55
     56(define (scheme-definitions-db-create env)
     57  (db-run env "CREATE TABLE definitions ( name varchar, page varchar );")
     58  (db-run env "CREATE TABLE tests ( expr varchar, expect varchar, cmp varchar, page varchar, blessed varchar );")
     59  (db-run env "CREATE TABLE tests_results ( version varchar, received varchar, pass boolean, date integer );"))
     60
     61(test-group definition-list?
     62  (test (definition-list? (string->stream "(foo bar)")))
     63  (test (not (definition-list? (string->stream "foo"))))
     64  (test (not (definition-list? (string->stream "")))))
     65
     66(define (definition-list? text)
     67  (and (not (stream-null? text))
     68       (char=? (stream-car text) #\()
     69       (char=? (stream-last text) #\))))
     70
     71(test-group get-definition-name
     72  (test (stream->string (get-definition-name (string->stream "(foo bar)")))
     73        "foo")
     74  (test (stream->string (get-definition-name (string->stream "bar")))
     75        "bar"))
     76
     77(define (get-definition-name text)
     78  (stream-take-while
     79    (complement char-whitespace?)
     80    (if (definition-list? text)
     81      (stream-cdr (stream-butlast text))
     82      text)))
     83
    3484(define (chicken-def name env)
    35   (let-from-environment env (text parse)
     85  (let-from-environment env (path text parse output-format)
    3686    ; Remove whitespace at beginning or end
    3787    (let ((text (stream-reverse
     
    4292                        char-whitespace?
    4393                        text))))))
    44       (parse
    45         (html-stream
    46           "["
    47           name
    48           "] {{"
    49           (if (and (not (stream-null? text))
    50                    (char=? (stream-car text) #\()
    51                    (char=? (stream-last text) #\)))
    52               (receive (symbol rest)
    53                        (stream-break char-whitespace?
    54                                      (stream-cdr (stream-butlast text)))
    55                 (html-stream
    56                   "('''"
    57                   symbol
    58                   "'''"
    59                   rest
    60                   ")}}\n\n"))
    61               text))))))
     94      (case output-format
     95        ((scheme-definitions)
     96          (let-from-environment env (return)
     97            (return (get-definition-name text)))
     98          stream-null)
     99        (else
     100          (parse
     101            (html-stream
     102              ((a name (format #f "xsvnwiki-scheme-~A" (stream->string (get-definition-name text))))
     103               "["
     104               name
     105               "] {{"
     106               (if (definition-list? text)
     107                 (receive (name rest)
     108                          (stream-break char-whitespace?
     109                                        (stream-cdr (stream-butlast text)))
     110                   (html-stream
     111                     "('''" name "'''" rest ")"))
     112                 text)
     113               "}}\n\n"))))))))
    62114
    63115(define (chicken-examples env)
     
    120172      stream-null)))
    121173
     174(define (update-notify-scheme env)
     175  (let-from-environment env (path-in path)
     176    (format (current-error-port) "Start scheme update: ~A~%" path)
     177    (db-run env "DELETE FROM definitions WHERE page = ?;" path)
     178    (stream-for-each
     179      (lambda (name)
     180        (format (current-error-port) "Insert definition: ~A~%" name)
     181        (db-run env "INSERT INTO definitions VALUES ( ?, ? );" name path))
     182      (iterator->stream
     183        (lambda (return stop)
     184          (wiki-extension
     185            'scheme-definitions
     186            (wiki-open path-in path)
     187            stream-null
     188            path
     189            (constantly stream-null)
     190            (lambda (name tail) tail)
     191            (make-hash-table)
     192            (environment-capture env (return))))))))
     193
     194(define (redirect-scheme env)
     195  (let-from-environment env (path return)
     196    (unless (file-exists? (svnwiki-repository-path env))
     197      (let ((targets (db-run env "SELECT page FROM definitions WHERE name = ?;" path)))
     198        (unless (stream-null? targets)
     199          (return
     200            (format #f "~A#xsvnwiki-scheme-~A"
     201                    (vector-ref (stream-car targets) 0)
     202                    path)))))))
     203
     204(svnwiki-extension-define 'redirect 'scheme-definitions redirect-scheme)
     205(svnwiki-extension-define 'update-notify-recursive 'scheme-definitions update-notify-scheme)
     206
    122207(svnwiki-extension-define 'code-break 'chickenegg chicken-egg-html)
     208
    123209(svnwiki-extension-define 'code-span 'procedure (cut chicken-def "procedure" <>))
    124210(svnwiki-extension-define 'code-span 'macro (cut chicken-def "macro" <>))
Note: See TracChangeset for help on using the changeset viewer.