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 }