source: project/stream-wiki/trunk/extensions/image.scm @ 5114

Last change on this file since 5114 was 5114, checked in by azul, 13 years ago

Bug fix. Use svnwiki-report-progress.

File size: 10.3 KB
Line 
1(require-extension syntax-case svn-post-commit-hooks orders format-modular html-stream)
2
3(define-syntax environment
4  (syntax-rules ()
5    ((environment original ((name expr) ...))
6     (lambda (op)
7       (case op
8         ((name) expr)
9         ...
10         (else (original op)))))
11    ((environment ((name expr) ...))
12     (environment (lambda (op)
13                    (warning "unbound variable (dynamic environment)" op)
14                    (if #f #f))
15                  ((name expr) ...)))))
16
17(define-syntax environment-get
18  (syntax-rules ()
19    ((environment-get env sym) (env 'sym))))
20
21(define-syntax let-from-environment
22  (syntax-rules ()
23    ((let-from-environment env (sym ...) body ...)
24     (let ((sym (environment-get env sym)) ...) body ...))))
25
26(define-syntax environment-capture
27  (syntax-rules ()
28    ((environment-capture env (sym ...))
29     (environment env ((sym sym) ...)))
30    ((environment-capture (sym ...))
31     (environment ((sym sym) ...)))))
32
33(define *image-javascript*
34#<<EOF
35if (typeof(svnwikiImage) != "object") {
36
37var svnwikiImage = new Object();
38
39svnwikiImage.cleanContent = function (element)
40{
41  while (element.hasChildNodes())
42    element.removeChild(element.firstChild);
43}
44
45svnwikiImage.makeLink = function ( target, content )
46{
47  var link = svnwikiImage.makeElement('A', content);
48  link.setAttribute('href', target);
49  return link;
50}
51
52svnwikiImage.makeElement = function ( type, content )
53{
54  var elem = document.createElement(type);
55  if (content)
56    elem.appendChild(content);
57  return elem;
58}
59
60svnwikiImage.pickSize = function (imgName, prefix, width, height)
61{
62  var sizesDiv = document.getElementById('svnwikiImageSizes' + imgName);
63  svnwikiImage.cleanContent(sizesDiv);
64  sizesDiv.appendChild(svnwikiImage.makeElement('p', document.createTextNode('Please wait, loading image...')));
65
66  var img = document.getElementById('svnwikiImage' + imgName);
67  img.width = width;
68  img.height = height;
69  img.src = prefix + '-' + Math.max(width, height);
70  img.onload = function () { svnwikiImage.cleanContent(sizesDiv); };
71}
72
73svnwikiImage.showSizes = function (imgName, sizes, prefix)
74{
75  var sizesDiv = document.getElementById('svnwikiImageSizes' + imgName);
76  var img = document.getElementById('svnwikiImage' + imgName);
77
78  if (sizesDiv.firstChild) {
79    svnwikiImage.cleanContent(sizesDiv);
80    return;
81  }
82
83  var ul = document.createElement('ul');
84  for (var j = 0; j < sizes.length; j ++) {
85    var target = "javascript:svnwikiImage.pickSize('" + imgName + "','" + prefix + "'," + sizes[j][0] + "," + sizes[j][1] + ");";
86    var text = document.createTextNode(sizes[j][0] + "x" + sizes[j][1]);
87    ul.appendChild(svnwikiImage.makeElement('li', svnwikiImage.makeLink(target, text)));
88  }
89  sizesDiv.appendChild(ul)
90}
91
92}
93EOF
94)
95
96(define (svnwiki-image-create-helper env)
97  (let-from-environment env (path-out program)
98    (when (and path-out (string=? program "post-commit"))
99      (assert (and 'svnwiki-image-create-helper (string? path-out)))
100      (unless (directory? (svnwiki-make-pathname path-out "xsvnwiki-helper"))
101        (create-directory (svnwiki-make-pathname path-out "xsvnwiki-helper")))
102      (unless (directory? (svnwiki-make-pathname (list path-out "xsvnwiki-helper") "image"))
103        (create-directory (svnwiki-make-pathname (list path-out "xsvnwiki-helper") "image")))
104      (write-file-with-tmp
105        (svnwiki-make-pathname (list "xsvnwiki-helper" "image") "image")
106        "text/javascript"
107        path-out
108        (string->stream
109          *image-javascript*)))))
110
111(define (svnwiki-image-show-sizes-link env random-id)
112  (let-from-environment env (path)
113    (format #f "javascript:svnwikiImage.showSizes('~A', [~{[~{~A~^, ~}]~^, ~}], '~A');"
114            random-id
115            (svnwiki-image-sizes-env env)
116            (last (string-split path "/")))))
117
118(define (svnwiki-image-handler-render env)
119  (let-from-environment env (initial-header-depth path-in path static-url)
120    (svnwiki-report-progress env "Image generate HTML: ~A~%" path)
121    (svnwiki-image-create-helper env)
122    (let ((random-id (random 100000)))
123      (html-stream
124        (format #f "<h~A>" initial-header-depth)
125        (svnwiki-get-title-html env)
126        (format #f "</h~A>" initial-header-depth)
127        ((ul class "svnwiki-image-links")
128         (li ((a href (svnwiki-image-show-sizes-link env random-id)) "All sizes")))
129        ((div id (format #f "svnwikiImageSizes~A" random-id)))
130        ((script type "text/javascript" src (format #f "~A/xsvnwiki-helper/image/image" static-url)))
131        ((img src (format #f "~A-~A" (last (string-split path "/")) *svnwiki-image-sizes-default*)
132              id (format #f "svnwikiImage~A" random-id)
133              ; TODO: Use svnwiki:title as the alt parameter.
134              alt (last (string-split path "/"))))
135        (let ((author (get-props-parents-first "svnwiki:image:author" path-in path #f))
136              (author-url (get-props-parents-first "svnwiki:image:author-url" path-in path #f)))
137          (cond
138            ((and author author-url)
139              (html-stream
140                (p (b "Author:")
141                   "\n"
142                   ((a href author-url) author))))
143            (author
144              (html-stream
145                (p (b "Author:") "\n" author)))
146            (else
147              stream-null)))
148        (let ((source (get-props-parents-first "svnwiki:image:source" path-in path #f)))
149          (if source
150            (html-stream
151              (p (b "Source:") "\n" ((a href source) source)))
152            stream-null))
153        (get-props-parents-first "svnwiki:image:description" path-in path stream-null)
154        (svnwiki-render-file-contents-tail env)))))
155
156(define (svnwiki-image-get-size env)
157  (let-from-environment env (path-in path)
158    (let ((input (open-input-pipe (format #f "anytopnm ~A | head -2" (svnwiki-path-escape (svnwiki-make-pathname path-in path))))))
159      ; Skip image type (eg "P4"):
160      (read input)
161      (values (read input) (read input)))))
162
163(define *svnwiki-image-sizes-default* 500)
164
165(define *svnwiki-image-sizes-list*
166  (list 100 240 *svnwiki-image-sizes-default* 1024))
167
168(define (svnwiki-image-sizes x y)
169  (append
170    (map
171      (lambda (size)
172        (list (inexact->exact (round (* size (min 1.0 (/ x y)))))
173              (inexact->exact (round (* size (min 1.0 (/ y x)))))))
174      (filter (lambda (size)
175                (<= size (* 0.9 (max x y))))
176              *svnwiki-image-sizes-list*))
177    `((,x ,y))))
178
179(define svnwiki-image-sizes-env
180  (compose svnwiki-image-sizes svnwiki-image-get-size))
181
182; Supported image types: The first will be the default format to generate.
183
184(define *svnwiki-image-types*
185  '("png"
186    "jpeg"))
187
188(define (svnwiki-image-update env)
189  (let-from-environment env (path-in path path-out)
190    (svnwiki-report-progress env "Image update start: ~A~%" path)
191    (let* ((type-input (svnwiki-repository-property-get
192                         "svn:mime-type"
193                         (svnwiki-make-pathname path-in path)
194                         #f))
195           (type (if (member type-input *svnwiki-image-types*) type-input (car *svnwiki-image-types*))))
196      (receive (size-x size-y)
197               (svnwiki-image-get-size env)
198        (for-each
199          (lambda (size)
200            (svnwiki-report-progress env "Image render generate: ~A: ~A by ~A pixels~%" path (car size) (cadr size))
201            (system
202              (format #f "anytopnm ~A | pnmscale -xysize ~A ~A | pnmto~A >~A"
203                      (svnwiki-path-escape (svnwiki-make-pathname path-in path))
204                      (car size)
205                      (cadr size)
206                      type
207                      (svnwiki-path-escape
208                        (svnwiki-make-pathname
209                          path-out
210                          (format #f "~A-~A" path (max (car size) (cadr size)))
211                          type)))))
212          (svnwiki-image-sizes size-x size-y))))))
213
214(define (svnwiki-image-code-break env)
215  (let-from-environment env (params path-in path output-format path-out-real)
216    (let* ((src (assoc 'src params))
217           (file (and src
218                      (svnwiki-path-canonical
219                        (stream->string
220                          (link-canonical
221                            (string->stream path)
222                            (cdr src)))))))
223      (cond
224        ((not (eq? output-format 'html))
225          (warning "<image> tag does not support output format" output-format)
226          stream-null)
227        ((not src)
228          (html-stream
229            (p "Invalid &lt;image&gt; tag: Must specify src")))
230        ((not (file-exists? (svnwiki-make-pathname path-in file)))
231          (html-stream
232            (p "Invalid &lt;image&gt; tag: src (" (i (cdr src)) ") does not exist in the repository.")))
233        (else
234          (let* ((class (cdr (or (assoc 'class params) (cons #f "image"))))
235                 (title
236                   (cdr
237                     (or (assoc 'caption params)
238                         (cons #f (svnwiki-repository-property-get
239                                    "svnwiki:title"
240                                    (svnwiki-make-pathname path-in file)
241                                    (string->stream (last (string-split file "/"))))))))
242                 (link (make-link-url path-out-real file #f))
243                 (size-spec (stream->number (cdr (or (assoc 'size params) (cons #f (number->stream *svnwiki-image-sizes-default*))))))
244                 (sizes-real (filter (cut <= <> size-spec) *svnwiki-image-sizes-list*))
245                 (size (if (null? sizes-real)
246                         *svnwiki-image-sizes-default*
247                         (apply max sizes-real))))
248            (receive (x y)
249                     (svnwiki-image-get-size (environment env ((path file))))
250              (html-stream
251                ((div class class)
252                 ((a href link title title)
253                  ((img src (format #f "~A-~A" link size)
254                        class class
255                        width  (inexact->exact (round (* size (min (/ x y) 1.0))))
256                        height (inexact->exact (round (* size (min (/ y x) 1.0)))))))
257                 ((p class class
258                     style (format #f "max-width: ~Apx;" (inexact->exact (round (* size (min (/ x y) 1.0))))))
259                  ((a href link title title) title)))))))))))
260
261(define *extensions*
262  `((image (render-file-contents ,svnwiki-image-handler-render)
263           (update ,svnwiki-image-update)
264           (code-break ,svnwiki-image-code-break))))
Note: See TracBrowser for help on using the repository browser.