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