source: project/release/4/sxml-fu/trunk/sxml-shortcuts.scm @ 20996

Last change on this file since 20996 was 20996, checked in by sjamaan, 11 years ago

sxml-fu: Convert pagination rules to starred forms and add a basic test (needs a lot more testing though)

File size: 3.7 KB
Line 
1;;; sxml-shortcuts.scm
2;
3; Copyright (c) 2004-2010 Peter Bex (Peter.Bex@xs4all.nl)
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without
7; modification, are permitted provided that the following conditions
8; are met:
9; 1. Redistributions of source code must retain the above copyright
10;    notice, this list of conditions and the following disclaimer.
11; 2. Redistributions in binary form must reproduce the above copyright
12;    notice, this list of conditions and the following disclaimer in the
13;    documentation and/or other materials provided with the distribution.
14; 3. Neither the name of Peter Bex nor the names of any contributors may
15;    be used to endorse or promote products derived from this software
16;    without specific prior written permission.
17;
18; THIS SOFTWARE IS PROVIDED BY PETER BEX AND CONTRIBUTORS ``AS IS'' AND ANY
19; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
21; DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS BE LIABLE
22; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
25; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
26; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
27; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
28; SUCH DAMAGE.
29
30(module sxml-shortcuts
31  (shortcut-rules shortcut-rules*)
32
33(import chicken scheme)
34
35(require-extension srfi-1 uri-common sxml-transforms sxml-fu)
36
37(define shortcut-rules*
38  `((url *macro* . ,(lambda (tag contents)
39                      (let ((href (if (uri-reference? (car contents))
40                                      (uri->string (car contents))
41                                      (car contents))))
42                       `(a (@ (href ,href))
43                           ,@(if (not (null? (cdr contents)))
44                                 (cdr contents)
45                                 (list href))))))
46    (pic *macro* . ,(lambda (tag contents)
47                      (let ((src (if (uri-reference? (car contents))
48                                     (uri->string (car contents))
49                                     (car contents)))
50                            (alt (cadr contents))
51                            (rest (cddr contents)))
52                        (let-optionals* rest ((title alt) more)
53                                        `(img (@ ,@(append `((src ,src)
54                                                             (alt ,alt)
55                                                             (title ,title)
56                                                             ,@more))))))))
57    ;; Maybe this one should be deprecated in favor of video?
58    ;; It's too quicktime-specific anyway...
59    (movie *macro* . ,(lambda (tag contents)
60                        (let ((src (if (uri-reference? (car contents))
61                                       (uri->string (car contents))
62                                       (car contents)))
63                              (title (cadr contents))
64                              (rest (cddr contents)))
65                         `(object (@ (type "video/quicktime"))
66                                  (param (@ (name "src") (value ,src)))
67                                  (param (@ (name "controller") (value "true")))
68                                  ,@rest
69                                  ;; Fallback if no viewer
70                                  (url ,src ,title)))))
71    . ,alist-conv-rules*))
72
73(define shortcut-rules (normal->starred-transformation-rules shortcut-rules*))
74
75)
Note: See TracBrowser for help on using the repository browser.