Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 221 lines (186 sloc) 6.071 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
513a9df @Aqua-Ye [doc] tools: changed files headers to MIT license
Aqua-Ye authored
4 This file is part of Opa.
fccc685 Initial open-source release
MLstate authored
5
513a9df @Aqua-Ye [doc] tools: changed files headers to MIT license
Aqua-Ye authored
6 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
fccc685 Initial open-source release
MLstate authored
7
513a9df @Aqua-Ye [doc] tools: changed files headers to MIT license
Aqua-Ye authored
8 The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
fccc685 Initial open-source release
MLstate authored
9
513a9df @Aqua-Ye [doc] tools: changed files headers to MIT license
Aqua-Ye authored
10 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
fccc685 Initial open-source release
MLstate authored
11 *)
12 (**
13 Adding hyperlink to the generated svg.
14 @author Mathieu Barbin
15 *)
16
17 (**
18 This module is an ad-hoc implementation for adding hyperlinks to
19 a svg file.
20 The format of the svg should be very specific, there is no parser for svg.
21
22 The format is the one seen in practice as the format produced by dot -Tsvg.
23 The hypothesis done is that any node is surrounded by a comment, indicating
24 the title of the node :
25 {[
26 <!-- qmlslicer -->
27 <g id="node39" class="node"><title>qmlslicer</title>
28 <ellipse style="fill:none;stroke:black;" cx="645" cy="-162" rx="52.8111" ry="18"/>
29 <text text-anchor="middle" x="645" y="-157.9" style="font-family:Times New Roman;font-size:14.00;">qmlslicer</text>
30 </g>
31 ]}
32
33
34 The preprocess proposed by this file is meant to add extra href annotation,
35 indexed by the name of the node.
36
37 So, if in the map you have a binding :
38 {[
39 qmlslicer -> "odep__lib_qmlslicer.svg"
40 ]}
41 the preprocess will return :
42 <!-- qmlslicer -->
43 <a xlink:href="odep__lib_qmlslicer.svg">
44 <g id="node39" class="node"><title>qmlslicer</title>
45 <ellipse style="fill:none;stroke:black;" cx="645" cy="-162" rx="52.8111" ry="18"/>
46 <text text-anchor="middle" x="645" y="-157.9" style="font-family:Times New Roman;font-size:14.00;">qmlslicer</text>
47 </g>
48 </a>
49
50
51 For using this application, you should give all the svg you want to process,
52 the link added correspond to all found file, suffixed with name.
53 In case of several matching file, the choosen link is unspecified.
54
55 Exemple:
56
57 odeplink toto.svg tutu.tata.svg
58
59 link toto -> "toto".svg
60 link tata -> tutu.tata.svg
61 *)
62
63 (* depends *)
64 module String = Base.String
65
66 let tmp = "odeplink.tmp"
67
68 (*
69 The set contains file without extension
70 *)
71 let find_suffix set suffix =
72 Return.set_checkpoint (
73 fun label ->
74 StringSet.iter (
75 fun elt ->
76 if String.is_suffix suffix elt
77 then Return.return label (Some (elt^".svg"))
78 else ()
79 ) set ;
80 None
81 )
82
83 (*
84 Given a list of file, compute the set of filename without extension
85 *)
86 let compute_set list =
87 List.fold_left (fun set file -> StringSet.add (File.chop_extension file) set)
88 StringSet.empty list
89
90 let pat_begin = "<!--\\(.*\\)-->"
91 let reg_begin = Str.regexp pat_begin
92
93 let pat_end = "</g>"
94 let reg_end = Str.regexp pat_end
95
96 let match_begin line =
97 let line = String.trim line in
98 if Str.string_match reg_begin line 0
99 then (
100 try
101 let word = Str.matched_group 1 line in
102 let word = String.trim word in
103 Some word
104 with
105 | Not_found -> None
106 )
107 else
108 None
109
110 let match_end line =
111 let line = String.trim line in
112 Str.string_match reg_end line 0
113
114 type env = string option
115 let start = None
116
117 let pp_line map env line output =
118 Printf.fprintf output "%s\n" line ;
119 match env with
120 | Some _ -> (
121 if match_end line
122 then (
123 Printf.fprintf output "</a>\n" ;
124 None
125 )
126 else env
127 )
128 | None -> (
129 (* search for a begin *)
130 match match_begin line with
131 | Some lib -> (
132 match map lib with
133 | Some link ->
134 Printf.fprintf output "<a xlink:href=%S>\n" link ;
135 Some lib
136 | None ->
137 env
138 )
139 | None -> env
140 )
141
142 let preprocess map input output =
143 try
144 let rec aux env =
145 let line = input_line input in
146 let env = pp_line map env line output in
147 aux env
148 in
149 aux start
150 with
151 | End_of_file ->
152 flush output ;
153 ()
154
155 let preprocess_file map filename =
156 let oc = open_out tmp in
157 let ic = open_in filename in
158 preprocess map ic oc ;
159 close_in ic ;
160 close_out oc ;
161 let _ = File.copy ~force:true tmp filename in
162 ()
163
164 (*
165 map a format, with NODE variable
166 *)
167 let node_pattern =
168 let buf = Buffer.create 124 in
169 let subst pat = function
170 | "NODE" -> pat
171 | e -> e
172 in
173 (fun pat node ->
174 Buffer.clear buf ;
175 Buffer.add_substitute buf (subst node) pat ;
176 Buffer.contents buf)
177
178
179 let link = ref None
180 let svg = ref []
181
182 let spec = [
183 (* l *)
184 "--link",
185 Arg.String (fun s -> link := Some s),
186 " Add external link. e.g. : path/to/file/$(NODE).html"
187 ]
188
9a4a8ee [enhance] help/manpages: global pass for improving help messages of O…
Mathieu Baudet authored
189 let usage_msg = Printf.sprintf "%s: svg hyperlink adder\nUsage: %s *.svg\n" Sys.argv.(0) Sys.argv.(0)
fccc685 Initial open-source release
MLstate authored
190
191 let anon_fun file =
192 match File.extension file with
193 | "svg" ->
194 svg := file :: !svg
195 | _ ->
196 Printf.eprintf "I don't know what to do with arg %S\n%s%!" file usage_msg ;
197 exit 1
198
199 let parse () =
9a4a8ee [enhance] help/manpages: global pass for improving help messages of O…
Mathieu Baudet authored
200 Arg.parse spec anon_fun (usage_msg^"Options:")
fccc685 Initial open-source release
MLstate authored
201
202 let _ =
203 parse ();
204 let set = compute_set !svg in
205 let map =
206 match !link with
207 | None -> find_suffix set
208 | Some pat -> (
209 fun node ->
210 match find_suffix set node with
211 | (Some _) as link -> link
212 | None ->
213 if String.is_word node
214 then
215 Some (node_pattern pat node)
216 else
217 None
218 )
219 in
220 List.iter (preprocess_file map) !svg
Something went wrong with that request. Please try again.