Updated copyright headers
[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 void set(const PropertySet &opts);
193 /// Get members into PropertySet
194 PropertySet get() const;
195 /// Convert to a string which can be parsed as a PropertySet
196 std::string toString() const;
197 } $struct_name;
198 EOF
199
200 $stext .= <<EOF;
201 namespace dai {
202
203 void ${class}::Properties::set(const PropertySet &opts)
204 {
205 const std::set<PropertyKey> &keys = opts.allKeys();
206 std::set<PropertyKey>::const_iterator i;
207 for(i=keys.begin(); i!=keys.end(); i++) {
208 EOF
209 for my $v (@vars) {
210 my ($type,$name,$default,$cmt) = @$v;
211 $stext .= <<EOF;
212 if(*i == "$name") continue;
213 EOF
214 }
215 $stext .= <<EOF;
216 DAI_THROWE(UNKNOWN_PROPERTY_TYPE, "$class: Unknown property " + *i);
217 }
218 EOF
219 for my $v (@vars) {
220 my ($type,$name,$default,$cmt) = @$v;
221 if(!defined $default) {
222 $stext .= <<EOF;
223 if(!opts.hasKey("$name"))
224 DAI_THROWE(NOT_ALL_PROPERTIES_SPECIFIED,"$class: Missing property \\\"$name\\\" for method \\\"\Q$class\E\\\"");
225 EOF
226 }
227
228 }
229 $stext .= <<EOF;
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 }