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