Made all "verbose" properties optional and unit tests should now also work on WINDOWS
[libdai.git] / scripts / regenerate-properties
1 #!/usr/bin/perl
2 #
3 # This file is part of libDAI - http://www.libdai.org/
4 #
5 # libDAI is licensed under the terms of the GNU General Public License version
6 # 2, or (at your option) any later version. libDAI is distributed without any
7 # warranty. See the file COPYING for more details.
8 #
9 # Copyright (C) 2009 Frederik Eaton [frederik at ofb dot net]
10
11
12 use warnings;
13 use strict;
14
15 use Cwd 'abs_path';
16
17 @ARGV == 2 or die "Need 2 arguments";
18
19 my ($header_file,$source_file) = @ARGV;
20 @ARGV=();
21
22 # Regular expressions for nested brackets (uses perl 5.10 features)
23 my ($nested_angle_brackets) = qr/(<(?:[^<>]++|(?1))*>)/;
24 my ($nested_curly_brackets) = qr/({(?:[^{}]++|(?1))*})/;
25 my ($nested_parentheses) = qr/(\((?:[^()]++|(?1))*\))/;
26
27 # Patterns to match generated code blocks
28 my ($gen_code_start_pat, $gen_code_end_pat, $props_start_pat) =
29 (qr(/\*.*GENERATED CODE: DO NOT EDIT.*),
30 qr(/\*.*END OF GENERATED CODE.*\*/),
31 qr(/\*.*PROPERTIES));
32 # Actual delimiters to use for generated code blocks
33 my ($gen_code_start, $gen_code_end) =
34 ("/* {{{ GENERATED CODE: DO NOT EDIT. Created by\n".
35 " $0 $header_file $source_file\n*/\n",
36 "/* }}} END OF GENERATED CODE */\n");
37
38 # Strings to hold text of files
39 my $header_buffer="";
40 my $source_buffer="";
41
42 # ----------------------------------------------------------------
43 # Useful routines
44
45 # remove leading and trailing whitespace
46 sub stripws ($) {
47 my ($s) = @_;
48 $s =~ s/^\s*//s;
49 $s =~ s/\s*$//s;
50 return $s;
51 }
52
53 # split comments and non-comments, returning 2-element array
54 # of (uncommented part, comments)
55 my $comment_pat = qr#(/\*[^*]*\*+(?:[^/*][^*]*\*+)*/|//[^\n]*)|("(?:\\.|[^"\\])*"|'(?:\\.|[^'\\])*'|.[^/"'\\]*)#;
56 sub sepcomment ($) {
57 my ($c) = @_;
58 my ($u) = $c;
59 $u =~ s#$comment_pat#defined $2 ? $2 : ""#gse;
60 $c =~ s#$comment_pat#defined $1 ? $1 : ""#gse;
61 return ($u, $c);
62 }
63
64 # Run diff, return output
65 sub getdiff ($$) {
66 my ($a,$b) = @_;
67 my $diff="";
68 open DIFF, "diff -u \Q$a\E \Q$b\E |"
69 or die "Couldn't run diff";
70 while(<DIFF>) {
71 $diff .= $_;
72 }
73 close DIFF;
74 return $diff;
75 }
76
77 sub myrename ($$) {
78 my ($a,$b) = @_;
79 $b = abs_path $b;
80 rename($a, $b) or die "Couldn't rename $a to $b";
81 }
82
83 sub writefile ($$) {
84 my ($buf, $f) = @_;
85 open OUT, ">", $f or die "Couldn't open $f for writing";
86 print OUT $buf;
87 close OUT;
88 }
89
90 our ($buffer);
91
92 # Step through file, appending lines to buffer
93 # - Lines which match generated code blocks are omitted
94 # - Other lines are passed to the subroutine. They are added to buffer
95 # unless the subroutine returns 1 (e.g. if it has already added them)
96 sub process_file (&$) {
97 my ($sub, $file) = @_;
98 local ($buffer) = "";
99 # step through lines of file, appending each one to buffer
100 open IN, "<", $file or die "Couldn't open $file for reading";
101 while (<IN>) {
102 # delete anything between GENERATED CODE etc.
103 if (/$gen_code_end_pat/) {
104 die "Unmatched generated code block end at $file line $.";
105 } elsif (/$gen_code_start_pat/) {
106 my $s = $.;
107 my $found=0;
108 while (<IN>) {
109 chomp;
110 if (/$gen_code_end_pat/) {
111 $found=1;
112 last;
113 }
114 }
115 die "Unterminated generated code block at $file line $s"
116 unless $found;
117 next;
118 } else {
119 my ($res) = &$sub;
120 next if $res;
121 }
122 $buffer .= $_;
123 }
124 close IN;
125 return $buffer;
126 }
127
128 # Parse a PROPERTIES() block
129 sub process_properties ($$$) {
130 my ($file, $start_line, $props_text) = @_;
131 my ($errline)="$file:$start_line";
132 $props_text =~ s/^.*PROPERTIES\s*($nested_parentheses)//s
133 or die "Malformed PROPERTIES, $errline: expected PROPERTIES(args)";
134 my ($args) = $1;
135 $args =~ s/^\(//g;
136 $args =~ s/\)$//g;
137 my (@args) = split /,/, $args;
138 @args == 2 or die "PROPERTIES needs two arguments at $errline";
139 my ($struct_name, $class) = @args;
140
141 $props_text =~ m/^\s*($nested_curly_brackets)\s*$/s
142 or die "Malformed PROPERTIES, $errline: expected {} after PROPERTIES";
143 my ($body) = $1;
144 $body =~ s/^{(.*)}$/$1/s; # get rid of curly brackets
145 my (@stmts) = split /;\s*\n/s, $body; # split on ";"
146 my (@typedecls) = ();
147 my (@vars) = ();
148 foreach my $s (@stmts) {
149 my ($s, $cmt) = sepcomment $s;
150 $cmt = stripws $cmt;
151 if($s =~ /^\s*$/s) { # extra ";"
152 next;
153 } elsif($s =~ /DAI_ENUM|typedef/) {
154 push @typedecls, [stripws $s, $cmt];
155 } else {
156 $s =~ /^\s*[a-zA-Z_][\w:]+\s*$nested_angle_brackets?/
157 or die "Couldn't match statement $s in PROPERTIES at $errline";
158 my $type = stripws $&;
159 my $name = stripws $';
160 my $default = undef;
161 if($name =~ /^(.*)=(.*)$/) {
162 $name = stripws $1;
163 $default = stripws $2;
164 }
165 push @vars, [$type, $name, $default, $cmt];
166 }
167 }
168
169 my ($stext) = "";
170 my ($text) = <<EOF;
171 struct Properties {
172 EOF
173 my $indent = (' 'x12);
174 for my $d (@typedecls) {
175 my ($decl,$cmt) = @$d;
176 if($cmt ne '') {
177 $text .= join("\n", map { "$indent$_" } split /\n/s, $cmt)."\n";
178 }
179 $text .= "$indent$decl;\n"
180 }
181 for my $v (@vars) {
182 my ($type,$name,$default,$cmt) = @$v;
183 if($cmt ne '') {
184 $text .= join("\n", map { "$indent$_" } split /\n/s, $cmt)."\n"
185 }
186 $text .= "$indent$type $name;\n";
187 }
188
189 $text .= <<EOF;
190
191 /// Set members from PropertySet
192 /** \\throw UNKNOWN_PROPERTY if a Property key is not recognized
193 * \\throw NOT_ALL_PROPERTIES_SPECIFIED if an expected Property is missing
194 */
195 void set(const PropertySet &opts);
196 /// Get members into PropertySet
197 PropertySet get() const;
198 /// Convert to a string which can be parsed as a PropertySet
199 std::string toString() const;
200 } $struct_name;
201 EOF
202
203 $stext .= <<EOF;
204 namespace dai {
205
206 void ${class}::Properties::set(const PropertySet &opts)
207 {
208 const std::set<PropertyKey> &keys = opts.keys();
209 std::string errormsg;
210 for( std::set<PropertyKey>::const_iterator i = keys.begin(); i != keys.end(); i++ ) {
211 EOF
212 for my $v (@vars) {
213 my ($type,$name,$default,$cmt) = @$v;
214 $stext .= <<EOF;
215 if( *i == "$name" ) continue;
216 EOF
217 }
218 $stext .= <<EOF;
219 errormsg = errormsg + "$class: Unknown property " + *i + "\\n";
220 }
221 if( !errormsg.empty() )
222 DAI_THROWE(UNKNOWN_PROPERTY, errormsg);
223 EOF
224 for my $v (@vars) {
225 my ($type,$name,$default,$cmt) = @$v;
226 if(!defined $default) {
227 $stext .= <<EOF;
228 if( !opts.hasKey("$name") )
229 errormsg = errormsg + "$class: Missing property \\\"$name\\\" for method \\\"\Q$class\E\\\"\\n";
230 EOF
231 }
232
233 }
234 $stext .= <<EOF;
235 if( !errormsg.empty() )
236 DAI_THROWE(NOT_ALL_PROPERTIES_SPECIFIED,errormsg);
237 EOF
238 for my $v (@vars) {
239 my ($type,$name,$default,$cmt) = @$v;
240 if(defined $default) {
241 $stext .= <<EOF;
242 if( opts.hasKey("$name") ) {
243 $name = opts.getStringAs<$type>("$name");
244 } else {
245 $name = $default;
246 }
247 EOF
248 } else {
249 $stext .= <<EOF;
250 $name = opts.getStringAs<$type>("$name");
251 EOF
252 }
253 }
254
255 $stext .= <<EOF;
256 }
257 PropertySet ${class}::Properties::get() const {
258 PropertySet opts;
259 EOF
260
261 for my $v (@vars) {
262 my ($type,$name,$default,$cmt) = @$v;
263 # $text .= qq{opts.set("$name", $name);};
264 $stext .= <<EOF;
265 opts.set("$name", $name);
266 EOF
267
268 }
269 $stext .= <<EOF;
270 return opts;
271 }
272 string ${class}::Properties::toString() const {
273 stringstream s(stringstream::out);
274 s << "[";
275 EOF
276
277 my ($i)=0;
278 for my $v (@vars) {
279 my ($type,$name,$default,$cmt) = @$v;
280 $i++;
281 my $c = ($i<@vars)?" << \",\"":"";
282 $stext .= <<EOF;
283 s << "$name=" << $name$c;
284 EOF
285 }
286
287 $stext .= <<EOF;
288 s << "]";
289 return s.str();
290 }
291 } // end of namespace dai
292 EOF
293 return ($gen_code_start.$text.$gen_code_end, $gen_code_start.$stext.$gen_code_end);
294 }
295
296 # ----------------------------------------------------------------
297 # Main loop
298
299 $source_buffer = process_file { return 0; } $source_file;
300 $source_buffer =~ s/\n+$//s;
301
302 $header_buffer = process_file {
303 if (/$props_start_pat/) {
304 # when we see something resembling properties, record it, and when we
305 # get to the end, process and emit the generated code
306 my $start_line = $.;
307 my $props_text = $_;
308 while (<IN>) {
309 last if(m(\*/));
310 $props_text .= $_;
311 }
312 $buffer .= $props_text;
313 $buffer .= $_;
314 my ($htext, $stext) = process_properties($header_file, $start_line, $props_text);
315 $buffer .= $htext;
316 $source_buffer .= "\n\n\n".$stext;
317 return 1;
318 }
319 return 0;
320 } $header_file;
321
322 # Write new contents of files to temporary locations
323 my $header_tmp = "$header_file.new";
324 my $source_tmp = "$source_file.new";
325 writefile ($header_buffer, $header_tmp);
326 writefile ($source_buffer, $source_tmp);
327
328 # Get a diff of changes, show it to the user, and ask for confirmation
329 my ($diff);
330 $diff = getdiff ($header_file, $header_tmp);
331 $diff .= getdiff ($source_file, $source_tmp);
332
333 if($diff eq '') {
334 warn "No differences\n";
335 } else {
336 my $pager = $ENV{PAGER} || "less";
337 open PAGER, "|$pager";
338 print PAGER $diff;
339 close PAGER;
340
341 print STDERR "Replace old with new version? (y|N) ";
342 $_=<>;
343 if (/^y/i) {
344 myrename($header_tmp, $header_file);
345 myrename($source_tmp, $source_file);
346 } else {
347 warn "Aborted\n";
348 }
349 }