f3601b93d7e7f55339280893ea06ba657cfb0f5c
[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 for(i=keys.begin(); i!=keys.end(); i++) {
198 EOF
199 for my $v (@vars) {
200 my ($type,$name,$default,$cmt) = @$v;
201 $stext .= <<EOF;
202 if(*i == "$name") continue;
203 EOF
204 }
205 $stext .= <<EOF;
206 DAI_THROWE(UNKNOWN_PROPERTY_TYPE, "$class: Unknown property " + *i);
207 }
208 EOF
209 for my $v (@vars) {
210 my ($type,$name,$default,$cmt) = @$v;
211 if(!defined $default) {
212 $stext .= <<EOF;
213 if(!opts.hasKey("$name"))
214 DAI_THROWE(NOT_ALL_PROPERTIES_SPECIFIED,"$class: Missing property \\\"$name\\\" for method \\\"\Q$class\E\\\"");
215 EOF
216 }
217
218 }
219 $stext .= <<EOF;
220 EOF
221 for my $v (@vars) {
222 my ($type,$name,$default,$cmt) = @$v;
223 if(defined $default) {
224 $stext .= <<EOF;
225 if(opts.hasKey("$name")) {
226 $name = opts.getStringAs<$type>("$name");
227 } else {
228 $name = $default;
229 }
230 EOF
231 } else {
232 $stext .= <<EOF;
233 $name = opts.getStringAs<$type>("$name");
234 EOF
235 }
236 }
237
238 $stext .= <<EOF;
239 }
240 PropertySet ${class}::Properties::get() const {
241 PropertySet opts;
242 EOF
243
244 for my $v (@vars) {
245 my ($type,$name,$default,$cmt) = @$v;
246 # $text .= qq{opts.set("$name", $name);};
247 $stext .= <<EOF;
248 opts.Set("$name", $name);
249 EOF
250
251 }
252 $stext .= <<EOF;
253 return opts;
254 }
255 string ${class}::Properties::toString() const {
256 stringstream s(stringstream::out);
257 s << "[";
258 EOF
259
260 my ($i)=0;
261 for my $v (@vars) {
262 my ($type,$name,$default,$cmt) = @$v;
263 $i++;
264 my $c = ($i<@vars)?" << \",\"":"";
265 $stext .= <<EOF;
266 s << "$name=" << $name$c;
267 EOF
268 }
269
270 $stext .= <<EOF;
271 s << "]";
272 return s.str();
273 }
274 } // end of namespace dai
275 EOF
276 return ($gen_code_start.$text.$gen_code_end, $gen_code_start.$stext.$gen_code_end);
277 }
278
279 # ----------------------------------------------------------------
280 # Main loop
281
282 $source_buffer = process_file { return 0; } $source_file;
283 $source_buffer =~ s/\n+$//s;
284
285 $header_buffer = process_file {
286 if (/$props_start_pat/) {
287 # when we see something resembling properties, record it, and when we
288 # get to the end, process and emit the generated code
289 my $start_line = $.;
290 my $props_text = $_;
291 while (<IN>) {
292 last if(m(\*/));
293 $props_text .= $_;
294 }
295 $buffer .= $props_text;
296 $buffer .= $_;
297 my ($htext, $stext) = process_properties($header_file, $start_line, $props_text);
298 $buffer .= $htext;
299 $source_buffer .= "\n\n\n".$stext;
300 return 1;
301 }
302 return 0;
303 } $header_file;
304
305 # Write new contents of files to temporary locations
306 my $header_tmp = "$header_file.new";
307 my $source_tmp = "$source_file.new";
308 writefile ($header_buffer, $header_tmp);
309 writefile ($source_buffer, $source_tmp);
310
311 # Get a diff of changes, show it to the user, and ask for confirmation
312 my ($diff);
313 $diff = getdiff ($header_file, $header_tmp);
314 $diff .= getdiff ($source_file, $source_tmp);
315
316 if($diff eq '') {
317 warn "No differences\n";
318 } else {
319 my $pager = $ENV{PAGER} || "less";
320 open PAGER, "|$pager";
321 print PAGER $diff;
322 close PAGER;
323
324 print STDERR "Replace old with new version? (y|N) ";
325 $_=<>;
326 if (/^y/i) {
327 myrename($header_tmp, $header_file);
328 myrename($source_tmp, $source_file);
329 } else {
330 warn "Aborted\n";
331 }
332 }