source: project/release/3/svnwiki-image/trunk/svnwiki-image.scm @ 12533

Last change on this file since 12533 was 12533, checked in by azul, 11 years ago

Importing svnwiki extensions.

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