Changeset 12623 in project


Ignore:
Timestamp:
11/28/08 02:21:53 (11 years ago)
Author:
azul
Message:

Lots of fixes. Generate downloadable files.

Location:
release/3/svnwiki-enscript/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/3/svnwiki-enscript/trunk/svnwiki-enscript.meta

    r12533 r12623  
    66 (synopsis "Provides an enscript tag that provides syntax highlighting using GNU enscript.")
    77 (category web)
    8  (needs svnwiki-extensions  svnwiki-extensions srfi-40 html-stream stream-ext)
     8 (needs svnwiki-extensions svnwiki-extensions srfi-40 html-stream stream-ext embedded-unittest stream-wiki)
    99 (license "GPL-3"))
  • release/3/svnwiki-enscript/trunk/svnwiki-enscript.scm

    r12533 r12623  
    44
    55(declare (export))
    6 (use svnwiki-extensions-support srfi-40 html-stream stream-ext)
     6(use svnwiki-extensions-support srfi-40 html-stream stream-ext embedded-unittest stream-wiki)
    77
    88(define (stream-take-while-all pred str)
     
    4040
    4141(define (tag-enscript env)
    42   (let-from-environment env (params text)
    43     (let ((highlight (assoc 'highlight params)))
    44       (if (or (not highlight)
    45               (stream-every (disjoin char-alphabetic? char-numeric?) (cdr highlight)))
    46         (receive (in out pid)
    47                  (process (format #f "enscript~A~A --color --language=html -p-"
    48                                   (if highlight " -E" "")
    49                                   (if highlight (stream->string (cdr highlight)) "")))
    50           (write-stream (stream-drop-while (lambda (a) (char=? a #\newline)) text) out)
    51           (close-output-port out)
    52           (let ((in-str (port->stream in)))
    53             (if (stream-null? in-str)
    54               (html-stream (pre text))
    55               (receive (code tail)
    56                        (stream-break-all
    57                          (lambda (x) (stream-prefix= x (list #\< #\H #\R #\>)))
    58                          (stream-drop-while-all
    59                            (complement (lambda (x) (stream-prefix= x (list #\< #\P #\R #\E #\>))))
    60                            in-str))
    61                 ; This is important: forces the waitpid on the pid!
    62                 (stream-length tail)
    63                 code))))
    64         stream-null))))
    65 
     42  (let-from-environment env (params text output-format)
     43    (let ((highlight (assoc 'highlight params))
     44          (filename (assoc 'filename params)))
     45      (format (current-error-port) "run: ~S, ~S, ~S~%" highlight filename output-format)
     46      (cond
     47        ((and highlight
     48              (not (stream-every (disjoin char-alphabetic? char-numeric?) (cdr highlight))))
     49         stream-null)
     50        ((eq? output-format 'html)
     51         (syntax-highlight (and highlight (stream->string (cdr highlight))) text))
     52        ((and (eq? output-format 'enscript)
     53              highlight
     54              filename)
     55         (let ((type (enscript-type->mime (stream->symbol (cdr highlight)))))
     56           (when type
     57             (let-from-environment env (return)
     58               (return (list (stream->string (cdr filename)) type text)))))
     59         stream-null)
     60        (else
     61          stream-null)))))
     62
     63(define (syntax-highlight language text)
     64  (receive (in out pid)
     65           (process (format #f "enscript~A~A --color --language=html -p-"
     66                            (if language " -E" "")
     67                            (or language "")))
     68    (write-stream (stream-drop-while (lambda (a) (char=? a #\newline)) text) out)
     69    (close-output-port out)
     70    (let ((in-str (port->stream in)))
     71      (if (stream-null? in-str)
     72        (html-stream (pre text))
     73        (receive (code tail)
     74                 (stream-break-all
     75                   (lambda (x) (stream-prefix= x (list #\< #\H #\R #\>)))
     76                   (stream-drop-while-all
     77                     (complement (lambda (x) (stream-prefix= x (list #\< #\P #\R #\E #\>))))
     78                     in-str))
     79                 ; This is important: forces the waitpid on the pid!
     80                 (stream-length tail)
     81                 code)))))
     82
     83; TODO: Add mime types for other languages supported by enscript.
     84
     85(define *enscript-types*
     86  '(((application x-sh) sh)
     87    ((application x-scheme) scheme)
     88    ((text html) html)))
     89
     90(define (enscript-type->mime type)
     91  (and-let* ((result (find (lambda (x) (eq? (cadr x) type))
     92                           *enscript-types*)))
     93    (format #f "~A/~A" (caar result) (cadar result))))
     94
     95(unittest (enscript-type->mime 'sh) "application/x-sh")
     96(unittest (not (enscript-type->mime 'unknown)))
     97
     98; Optionals parameters are used for testing only.  Don't use them for any other
     99; purpose, they may change.
     100
     101(define (mime->enscript-type env . rest)
     102  (let-optionals rest ((prop-get svnwiki-repository-property-get))
     103    (let-from-environment env (path-in path)
     104      (and-let* ((type-input (prop-get
     105                               "svn:mime-type"
     106                               (svnwiki-make-pathname path-in path)
     107                               #f))
     108                 (ctype (content-type-make type-input))
     109                 (data (assoc (list (string->symbol (content-type-type ctype))
     110                                    (string->symbol (content-type-subtype ctype)))
     111                              *enscript-types*)))
     112        (cadr data)))))
     113
     114(unittest (mime->enscript-type
     115            (environment ((path-in "/tmp") (path "/foo")))
     116            (lambda (type path default)
     117              (if (and (string=? path "/tmp/foo")
     118                       (string=? type "svn:mime-type"))
     119                "application/x-sh"
     120                (error "Invalid call" path type))))
     121          'sh)
     122
     123(unittest (not (mime->enscript-type
     124                 (environment ((path-in "/tmp") (path "/foo")))
     125                 (lambda (type path default) default))))
     126
     127(define (svnwiki-enscript-handler-render env)
     128  (and-let* ((type (mime->enscript-type env)))
     129    (let-from-environment env (path-in path return initial-header-depth)
     130      (svnwiki-report-progress env "Enscript ~A -> HTML: ~A~%" type path)
     131      (let ((random-id (random 100000)))
     132        (return
     133          (html-stream
     134            (format #f "<h~A>" initial-header-depth)
     135            (svnwiki-get-title-html env)
     136            (format #f "</h~A>" initial-header-depth)
     137            (syntax-highlight
     138              type
     139              (wiki-open-text path-in path))
     140            (svnwiki-render-file-contents-tail env)))))))
     141
     142(define (stream-group str key-proc)
     143  (let ((hash (make-hash-table))
     144        (order '()))
     145    (stream-for-each
     146      (lambda (x)
     147        (let ((key (key-proc x)))
     148          (unless (hash-table-exists? hash key)
     149            (set! order (cons key order)))
     150          (hash-table-set! hash key
     151            (cons x (hash-table-ref/default hash key '())))))
     152      str)
     153    (stream-map
     154      (compose list->stream reverse (cut hash-table-ref hash <>))
     155      (list->stream (reverse order)))))
     156
     157(unittest (map stream->list (stream->list (stream-group (stream 1 2 3 4 5) even?)))
     158          '((1 3 5) (2 4)))
     159
     160(define (group-chunks chunks)
     161  (stream-group chunks (lambda (x) (list (car x) (cadr x)))))
     162
     163(define (enscript-make-pathname path subpath . rest)
     164  (let-optionals rest ((mime #f))
     165    (svnwiki-make-pathname
     166      (list (svnwiki-dirname path)
     167            "xsvnwiki-enscript"
     168            (svnwiki-basename path))
     169      (stream->string
     170        (stream-map
     171          (lambda (c)
     172            (if (or (char-alphabetic? c)
     173                    (char-numeric? c)
     174                    (string-index "-" c))
     175              c
     176              #\-))
     177          (string->stream (svnwiki-basename subpath))))
     178      (mime->ending mime))))
     179
     180(unittest (enscript-make-pathname "foo/bar" "~/bin/xload")
     181          "foo/xsvnwiki-enscript/bar/xload")
     182
     183(unittest (enscript-make-pathname "foo/bar" "bin/../../../../../../xload")
     184          "foo/xsvnwiki-enscript/bar/xload")
     185
     186(unittest (enscript-make-pathname "bar" "~/bin/xload")
     187          "xsvnwiki-enscript/bar/xload")
     188
     189(unittest (enscript-make-pathname "bar" "xload.may-there")
     190          "xsvnwiki-enscript/bar/xload-may-there")
     191
     192(unittest (enscript-make-pathname "bar" "xload" "application/x-scheme")
     193          "xsvnwiki-enscript/bar/xload.scm")
     194
     195(define (enscript-update-notify env)
     196  (let-from-environment env (path path-out path-in path)
     197    (format (current-error-port) "Enscript-update: ~A: ~A~%" path-in path)
     198    (unless (or (directory? (svnwiki-make-pathname path-in path))
     199                (symbolic-link? (svnwiki-make-pathname path-in path))
     200                (svnwiki-is-raw? path-in path)
     201                (svnwiki-is-discuss? path))
     202      (stream-for-each
     203        (lambda (data)
     204          (format (current-error-port) "Generate file: ~A~%" (enscript-make-pathname path (car (stream-car data))))
     205          (write-file-with-tmp
     206            (enscript-make-pathname path (car (stream-car data)))
     207            (cadr (stream-car data))
     208            path-out
     209            (stream-concatenate
     210              (stream-map caddr data))))
     211        (get-files env)))))
     212
     213; Returns a stream where every element is a list of the form (path mime-type
     214; content), where path is a string with the name in the <enscript> tags'
     215; filename parameter, mime-type is a string computed based on the highlight
     216; parameter and content is a stream of characters with the result of appending
     217; all the contents of the <enscript> tags with this path and mime-type.
     218
     219(define (get-files env)
     220  (let-from-environment env (path-in path)
     221    (group-chunks
     222      (iterator->stream
     223        (lambda (return stop)
     224          (wiki-extension
     225            'enscript
     226            (wiki-open path-in path)
     227            stream-null
     228            path
     229            (constantly stream-null)
     230            (lambda (name tail) tail)
     231            (make-hash-table)
     232            (environment-capture env (return))))))))
     233
     234(define (enscript-actions-links env)
     235  (let-from-environment env (path-in path)
     236    (stream-for-each
     237      (lambda (data)
     238        (svnwiki-file-action-link
     239          env
     240          (enscript-make-pathname path (car (stream-car data)) (cadr (stream-car data)))
     241          (format #f "Download: ~A" (car (stream-car data)))))
     242      (get-files env))))
     243
     244(svnwiki-extension-define 'files-actions-links 'enscript enscript-actions-links)
     245(svnwiki-extension-define 'update-notify-recursive 'enscript enscript-update-notify)
    66246(svnwiki-extension-define 'code-span 'enscript tag-enscript)
     247(svnwiki-extension-define 'render-file-contents 'enscript svnwiki-enscript-handler-render)
Note: See TracChangeset for help on using the changeset viewer.