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

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

Importando.

File size: 10.1 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-image-create-helper env)
121    (let ((random-id (random 100000)))
122      (html-stream
123        (format #f "<h~A>" initial-header-depth)
124        (svnwiki-get-title-html env)
125        (format #f "</h~A>" initial-header-depth)
126        ((ul class "svnwiki-image-links")
127         (li ((a href (svnwiki-image-show-sizes-link env random-id)) "All sizes")))
128        ((div id (format #f "svnwikiImageSizes~A" random-id)))
129        ((script type "text/javascript" src (format #f "~A/xsvnwiki-helper/image/image" static-url)))
130        ((img src (format #f "~A-~A" (last (string-split path "/")) *svnwiki-image-sizes-default*)
131              id (format #f "svnwikiImage~A" random-id)
132              ; TODO: Use svnwiki:title as the alt parameter.
133              alt (last (string-split path "/"))))
134        (let ((author (get-props-parents-first "svnwiki:image:author" path-in path #f))
135              (author-url (get-props-parents-first "svnwiki:image:author-url" path-in path #f)))
136          (cond
137            ((and author author-url)
138              (html-stream
139                (p (b "Author:")
140                   "\n"
141                   ((a href author-url) author))))
142            (author
143              (html-stream
144                (p (b "Author:") "\n" author)))
145            (else
146              stream-null)))
147        (let ((source (get-props-parents-first "svnwiki:image:source" path-in path #f)))
148          (if source
149            (html-stream
150              (p (b "Source:") "\n" ((a href source) source)))
151            stream-null))
152        (get-props-parents-first "svnwiki:image:description" path-in path stream-null)
153        (svnwiki-render-file-contents-tail env)))))
154
155(define (svnwiki-image-get-size env)
156  (let-from-environment env (path-in path)
157    (let ((input (open-input-pipe (format #f "anytopnm ~A | head -2" (svnwiki-path-escape (svnwiki-make-pathname path-in path))))))
158      ; Skip image type (eg "P4"):
159      (read input)
160      (values (read input) (read input)))))
161
162(define *svnwiki-image-sizes-default* 500)
163
164(define *svnwiki-image-sizes-list*
165  (list 100 240 *svnwiki-image-sizes-default* 1024))
166
167(define (svnwiki-image-sizes x y)
168  (append
169    (map
170      (lambda (size)
171        (list (inexact->exact (round (* size (min 1.0 (/ x y)))))
172              (inexact->exact (round (* size (min 1.0 (/ y x)))))))
173      (filter (lambda (size)
174                (<= size (* 0.9 (max x y))))
175              *svnwiki-image-sizes-list*))
176    (list x y)))
177
178(define svnwiki-image-sizes-env
179  (compose svnwiki-image-sizes svnwiki-image-get-size))
180
181; Supported image types: The first will be the default format to generate.
182
183(define *svnwiki-image-types*
184  '("png"
185    "jpeg"))
186
187(define (svnwiki-image-update env)
188  (let-from-environment env (path-in path path-out)
189    (let* ((type-input (svnwiki-repository-property-get
190                         "svn:mime-type"
191                         (svnwiki-make-pathname path-in path)
192                         #f))
193           (type (if (member type-input *svnwiki-image-types*) type-input (car *svnwiki-image-types*))))
194      (receive (size-x size-y)
195               (svnwiki-image-get-size env)
196        (for-each
197          (lambda (size)
198            (system
199              (format #f "anytopnm ~A | pnmscale -xysize ~A ~A | pnmto~A >~A"
200                      (svnwiki-path-escape (svnwiki-make-pathname path-in path))
201                      (car size)
202                      (cadr size)
203                      type
204                      (svnwiki-path-escape
205                        (svnwiki-make-pathname
206                          path-out
207                          (format #f "~A-~A" path (max (car size) (cadr size)))
208                          type)))))
209          (svnwiki-image-sizes size-x size-y))))))
210
211(define (svnwiki-image-code-break env)
212  (let-from-environment env (params path-in path output-format path-out-real)
213    (let* ((src (assoc 'src params))
214           (file (and src
215                      (svnwiki-path-canonical
216                        (stream->string
217                          (link-canonical
218                            (string->stream path)
219                            (cdr src)))))))
220      (cond
221        ((not (eq? output-format 'html))
222          (warning "<image> tag does not support output format" output-format)
223          stream-null)
224        ((not src)
225          (html-stream
226            (p "Invalid &lt;image&gt; tag: Must specify src")))
227        ((not (file-exists? (svnwiki-make-pathname path-in file)))
228          (html-stream
229            (p "Invalid &lt;image&gt; tag: src (" (i (cdr src)) ") does not exist in the repository.")))
230        (else
231          (let* ((class (cdr (or (assoc 'class params) (cons #f "image"))))
232                 (title
233                   (cdr
234                     (or (assoc 'caption params)
235                         (cons #f (svnwiki-repository-property-get
236                                    "svnwiki:title"
237                                    (svnwiki-make-pathname path-in file)
238                                    (string->stream (last (string-split file "/"))))))))
239                 (link (make-link-url path-out-real file #f))
240                 (size-spec (stream->number (cdr (or (assoc 'size params) (cons #f (number->stream *svnwiki-image-sizes-default*))))))
241                 (sizes-real (filter (cut <= <> size-spec) *svnwiki-image-sizes-list*))
242                 (size (if (null? sizes-real)
243                         *svnwiki-image-sizes-default*
244                         (apply max sizes-real))))
245            (receive (x y)
246                     (svnwiki-image-get-size (environment env ((path file))))
247              (html-stream
248                ((div class class)
249                 ((a href link title title)
250                  ((img src (format #f "~A-~A" link size)
251                        class class
252                        width  (inexact->exact (round (* size (min (/ x y) 1.0))))
253                        height (inexact->exact (round (* size (min (/ y x) 1.0)))))))
254                 ((p class class
255                     style (format #f "max-width: ~Apx;" (inexact->exact (round (* size (min (/ x y) 1.0))))))
256                  ((a href link title title) title)))))))))))
257
258(define *extensions*
259  `((image (render-file-contents ,svnwiki-image-handler-render)
260           (update ,svnwiki-image-update)
261           (code-break ,svnwiki-image-code-break))))
Note: See TracBrowser for help on using the repository browser.