git.hungrycats.org Git - xscreensaver/blob - hacks/check-configs.pl

   1 #!/usr/bin/perl -w
   2 # Copyright © 2008-2013 Jamie Zawinski <jwz@jwz.org>
   3 #
   4 # Permission to use, copy, modify, distribute, and sell this software and its
   5 # documentation for any purpose is hereby granted without fee, provided that
   6 # the above copyright notice appear in all copies and that both that
   7 # copyright notice and this permission notice appear in supporting
   8 # documentation.  No representations are made about the suitability of this
   9 # software for any purpose.  It is provided "as is" without express or
  10 # implied warranty.
  11 #
  12 # This parses the .c and .xml files and makes sure they are in sync: that
  13 # options are spelled the same, and that all the numbers are in sync.
  14 #
  15 # Created:  1-Aug-2008.
  16
  17 require 5;
  18 use diagnostics;
  19 use strict;
  20
  21 my $progname = $0; $progname =~ s@.*/@@g;
  22 my $version = q{ $Revision: 1.7 $ }; $version =~ s/^[^\d]+([\d.]+).*/$1/;
  23
  24 my $verbose = 0;
  25
  26
  27 my $xlockmore_default_opts = '';
  28 foreach (qw(count cycles delay ncolors size font)) {
  29   $xlockmore_default_opts .= "{\"-$_\", \".$_\", XrmoptionSepArg, 0},\n";
  30 }
  31 $xlockmore_default_opts .=
  32  "{\"-wireframe\", \".wireframe\", XrmoptionNoArg, \"true\"},\n" .
  33  "{\"-3d\", \".use3d\", XrmoptionNoArg, \"true\"},\n";
  34
  35 my $thread_default_opts =
  36   "{\"-threads\",    \".useThreads\", XrmoptionNoArg, \"True\"},\n" .
  37   "{\"-no-threads\", \".useThreads\", XrmoptionNoArg, \"False\"},\n";
  38
  39 my $analogtv_default_opts = '';
  40 foreach (qw(color tint brightness contrast)) {
  41   $analogtv_default_opts .= "{\"-tv-$_\", \".TV$_\", XrmoptionSepArg, 0},\n";
  42 }
  43
  44 $analogtv_default_opts .= $thread_default_opts;
  45
  46
  47
  48 # Returns two tables:
  49 # - A table of the default resource values.
  50 # - A table of "-switch" => "resource: value", or "-switch" => "resource: %"
  51 #
  52 sub parse_src($) {
  53   my ($saver) = @_;
  54   my $file = lc($saver) . ".c";
  55
  56   # kludge...
  57   $file = 'apple2-main.c' if ($file eq 'apple2.c');
  58   $file = 'sproingiewrap.c' if ($file eq 'sproingies.c');
  59   $file = 'b_lockglue.c' if ($file eq 'bubble3d.c');
  60   $file = 'polyhedra-gl.c' if ($file eq 'polyhedra.c');
  61   $file = 'companion.c' if ($file eq 'companioncube.c');
  62
  63   $file = "glx/$file" unless (-f $file);
  64   my $body = '';
  65   local *IN;
  66   open (IN, "<$file") || error ("$file: $!");
  67   while (<IN>) { $body .= $_; }
  68   close IN;
  69   $file =~ s@^.*/@@;
  70
  71   my $xlockmore_p = 0;
  72   my $thread_p = ($body =~ m/THREAD_DEFAULTS/);
  73   my $analogtv_p = ($body =~ m/ANALOGTV_DEFAULTS/);
  74
  75   $body =~ s@/\*.*?\*/@@gs;
  76   $body =~ s@^#\s*(if|ifdef|ifndef|elif|else|endif).*$@@gm;
  77   $body =~ s/(THREAD|ANALOGTV)_(DEFAULTS|OPTIONS)//gs;
  78
  79   print STDERR "$progname: $file: defaults:\n" if ($verbose > 2);
  80   my %res_to_val;
  81   if ($body =~ m/_defaults\s*\[\]\s*=\s*{(.*?)}\s*;/s) {
  82     foreach (split (/,\s*\n/, $1)) {
  83       s/^\s*//s;
  84       s/\s*$//s;
  85       next if m/^0?$/s;
  86       my ($key, $val) = m@^\"([^:\s]+)\s*:\s*(.*?)\s*\"$@;
  87       print STDERR "$progname: $file: unparsable: $_\n" unless $key;
  88       $key =~ s/^[.*]//s;
  89       $res_to_val{$key} = $val;
  90       print STDERR "$progname: $file:   $key = $val\n" if ($verbose > 2);
  91     }
  92   } elsif ($body =~ m/\#\s*define\s*DEFAULTS\s*\\?\s*(.*?)\n[\n#]/s) {
  93     $xlockmore_p = 1;
  94     my $str = $1;
  95     $str =~ s/\"\s*\\\n\s*\"//gs;
  96     $str =~ m/^\s*\"(.*?)\"\s*\\?\s*$/ ||
  97       error ("$file: unparsable defaults: $str");
  98     $str = $1;
  99     $str =~ s/\s*\\n\s*/\n/gs;
 100     foreach (split (/\n/, $str)) {
 101       my ($key, $val) = m@^([^:\s]+)\s*:\s*(.*?)\s*$@;
 102       print STDERR "$progname: $file: unparsable: $_\n" unless $key;
 103       $key =~ s/^[.*]//s;
 104       $res_to_val{$key} = $val;
 105       print STDERR "$progname: $file:   $key = $val\n" if ($verbose > 2);
 106     }
 107
 108     while ($body =~ s/^#\s*define\s+(DEF_([A-Z\d_]+))\s+\"([^\"]+)\"//m) {
 109       my ($key1, $key2, $val) = ($1, lc($2), $3);
 110       $key2 =~ s/_(.)/\U$1/gs;  # "foo_bar" -> "fooBar"
 111       $key2 =~ s/Rpm/RPM/;      # kludge
 112       $res_to_val{$key2} = $val;
 113       print STDERR "$progname: $file:   $key1 ($key2) = $val\n"
 114         if ($verbose > 2);
 115     }
 116
 117   } else {
 118     error ("$file: no defaults");
 119   }
 120
 121   $body =~ m/XSCREENSAVER_MODULE(_2)?\s*\(\s*\"([^\"]+)\"/ ||
 122     error ("$file: no module name");
 123   $res_to_val{progclass} = $2;
 124   $res_to_val{doFPS} = 'false';
 125   print STDERR "$progname: $file:   progclass = $2\n" if ($verbose > 2);
 126
 127   print STDERR "$progname: $file: switches to resources:\n"
 128     if ($verbose > 2);
 129   my %switch_to_res;
 130   $switch_to_res{-fps} = 'doFPS: true';
 131   $switch_to_res{-fg}  = 'foreground: %';
 132   $switch_to_res{-bg}  = 'background: %';
 133
 134   my ($ign, $opts) = ($body =~ m/(_options|\bopts)\s*\[\]\s*=\s*{(.*?)}\s*;/s);
 135   if  ($xlockmore_p || $thread_p || $analogtv_p || $opts) {
 136     $opts = '' unless $opts;
 137     $opts .= ",\n$xlockmore_default_opts" if ($xlockmore_p);
 138     $opts .= ",\n$thread_default_opts" if ($thread_p);
 139     $opts .= ",\n$analogtv_default_opts" if ($analogtv_p);
 140
 141     foreach (split (/,\s*\n/, $opts)) {
 142       s/^\s*//s;
 143       s/\s*$//s;
 144       next if m/^$/s;
 145       next if m/^{\s*0\s*,/s;
 146       my ($switch, $res, $type, $v0, $v1, $v2) =
 147         m@^ \s* { \s * \"([^\"]+)\" \s* ,
 148                   \s * \"([^\"]+)\" \s* ,
 149                   \s * ([^\s]+)     \s* ,
 150                   \s * (\"([^\"]*)\"|([a-zA-Z\d_]+)) \s* }@xi;
 151       print STDERR "$progname: $file: unparsable: $_\n" unless $switch;
 152       my $val = defined($v1) ? $v1 : $v2;
 153       $val = '%' if ($type eq 'XrmoptionSepArg');
 154       $res =~ s/^[.*]//s;
 155       $res =~ s/^[a-z\d]+\.//si;
 156       $switch =~ s/^\+/-no-/s;
 157
 158       $val = "$res: $val";
 159       if (defined ($switch_to_res{$switch})) {
 160         print STDERR "$progname: $file:   DUP! $switch = \"$val\"\n"
 161           if ($verbose > 2);
 162       } else {
 163         $switch_to_res{$switch} = $val;
 164         print STDERR "$progname: $file:   $switch = \"$val\"\n"
 165           if ($verbose > 2);
 166       }
 167     }
 168   } else {
 169     error ("$file: no options");
 170   }
 171
 172   return (\%res_to_val, \%switch_to_res);
 173 }
 174
 175 # Returns a list of:
 176 #    "resource = default value"
 177 # or "resource != non-default value"
 178 #
 179 sub parse_xml($$) {
 180   my ($saver, $switch_to_res) = @_;
 181   my $file = "config/" . lc($saver) . ".xml";
 182   my $body = '';
 183   local *IN;
 184   open (IN, "<$file") || error ("$file: $!");
 185   while (<IN>) { $body .= $_; }
 186   close IN;
 187   $file =~ s@^.*/@@;
 188
 189   my @result = ();
 190
 191   $body =~ s/<!--.*?-->/ /gsi;
 192
 193   $body =~ s/\s+/ /gs;
 194   $body =~ s/</\001</gs;
 195   $body =~ s/\001(<option)/$1/gs;
 196
 197   print STDERR "$progname: $file: options:\n" if ($verbose > 2);
 198   foreach (split (m/\001/, $body)) {
 199     next if (m/^\s*$/s);
 200     my ($type, $args) = m@^<([?/]?[-_a-z]+)\b\s*(.*)$@si;
 201     error ("$progname: $file: unparsable: $_") unless $type;
 202     next if ($type =~ m@^/@);
 203
 204     if ($type =~ m/^([hv]group|\?xml|command|string|file|_description|xscreensaver-(image|text|updater))/s) {
 205
 206     } elsif ($type eq 'screensaver') {
 207       my ($name) = ($args =~ m/\b_label\s*=\s*\"([^\"]+)\"/);
 208       my $val = "progclass = $name";
 209       push @result, $val;
 210       print STDERR "$progname: $file:   name:    $name\n" if ($verbose > 2);
 211
 212     } elsif ($type eq 'number') {
 213       my ($arg) = ($args =~ m/\barg\s*=\s*\"([^\"]+)\"/);
 214       my ($val) = ($args =~ m/\bdefault\s*=\s*\"([^\"]+)\"/);
 215       $val = '' unless defined($val);
 216
 217       my $switch = $arg;
 218       $switch =~ s/\s+.*$//;
 219       my ($res) = $switch_to_res->{$switch};
 220       error ("$file: no resource for $type switch \"$arg\"") unless $res;
 221       $res =~ s/: \%$//;
 222       error ("$file: unparsable value: $res") if ($res =~ m/:/);
 223       $val = "$res = $val";
 224       push @result, $val;
 225       print STDERR "$progname: $file:   number:  $val\n" if ($verbose > 2);
 226
 227     } elsif ($type eq 'boolean') {
 228       my ($set)   = ($args =~ m/\barg-set\s*=\s*\"([^\"]+)\"/);
 229       my ($unset) = ($args =~ m/\barg-unset\s*=\s*\"([^\"]+)\"/);
 230       my ($arg) = $set || $unset || error ("$file: unparsable: $args");
 231       my ($res) = $switch_to_res->{$arg};
 232         error ("$file: no resource for boolean switch \"$arg\"") unless $res;
 233       my ($res2, $val) = ($res =~ m/^(.*?): (.*)$/s);
 234       error ("$file: unparsable boolean resource: $res") unless $res2;
 235       $res = $res2;
 236 #      $val = ($set ? "$res != $val" : "$res = $val");
 237       $val = "$res != $val";
 238       push @result, $val;
 239       print STDERR "$progname: $file:   boolean: $val\n" if ($verbose > 2);
 240
 241     } elsif ($type eq 'select') {
 242       $args =~ s/</\001</gs;
 243       my @opts = split (/\001/, $args);
 244       shift @opts;
 245       my $unset_p = 0;
 246       my $this_res = undef;
 247       foreach (@opts) {
 248         error ("$file: unparsable: $_") unless (m/^<option\s/);
 249         my ($set) = m/\barg-set\s*=\s*\"([^\"]+)\"/;
 250         if ($set) {
 251           my ($set2, $val) = ($set =~ m/^(.*?) (.*)$/s);
 252           $set = $set2 if ($set2);
 253           my ($res) = $switch_to_res->{$set};
 254           error ("$file: no resource for select switch \"$set\"") unless $res;
 255
 256           my ($res2, $val2) = ($res =~ m/^(.*?): (.*)$/s);
 257           error ("$file: unparsable select resource: $res") unless $res2;
 258           $res = $res2;
 259           $val = $val2 unless ($val2 eq '%');
 260
 261           error ("$file: mismatched resources: $res vs $this_res")
 262             if (defined($this_res) && $this_res ne $res);
 263           $this_res = $res;
 264
 265           $val = "$res != $val";
 266           push @result, $val;
 267           print STDERR "$progname: $file:   select:  $val\n" if ($verbose > 2);
 268
 269         } else {
 270           error ("$file: multiple default options: $set") if ($unset_p);
 271           $unset_p++;
 272         }
 273       }
 274
 275     } else {
 276       error ("$file: unknown type \"$type\" for no arg");
 277     }
 278   }
 279
 280   return @result;
 281 }
 282
 283
 284 sub check_config($) {
 285   my ($saver) = @_;
 286
 287   # kludge
 288   return 0 if ($saver =~ m/(-helper)$/);
 289
 290   my ($src_opts, $switchmap) = parse_src ($saver);
 291   my (@xml_opts) = parse_xml ($saver, $switchmap);
 292
 293   my $failures = 0;
 294   foreach my $claim (@xml_opts) {
 295     my ($res, $compare, $xval) = ($claim =~ m/^(.*) (=|!=) (.*)$/s);
 296     error ("$saver: unparsable xml claim: $_") unless $compare;
 297
 298     my $sval = $src_opts->{$res};
 299     if ($res =~ m/^TV/) {
 300       print STDERR "$progname: $saver: OK: skipping \"$res\"\n"
 301         if ($verbose > 1);
 302     } elsif (!defined($sval)) {
 303       print STDERR "$progname: $saver: $res: not in source\n";
 304     } elsif ($compare eq '!='
 305              ? $sval eq $xval
 306              : $sval ne $xval) {
 307       print STDERR "$progname: $saver: " .
 308         "src has \"$res = $sval\", xml has \"$claim\"\n";
 309       $failures++;
 310     } elsif ($verbose > 1) {
 311       print STDERR "$progname: $saver: OK: \"$res = $sval\" vs \"$claim\"\n";
 312     }
 313   }
 314
 315   # Now make sure the progclass in the source and XML also matches
 316   # the XCode target name.
 317   #
 318   my $obd = "../OSX/build/Debug";
 319   if (-d $obd) {
 320     my $progclass = $src_opts->{progclass};
 321     my $f = (glob("$obd/$progclass.saver*"))[0];
 322     if (!$f && $progclass ne 'Flurry') {
 323       print STDERR "$progname: $progclass.saver does not exist\n";
 324       $failures++;
 325     }
 326   }
 327
 328   print STDERR "$progname: $saver: OK\n"
 329     if ($verbose == 1 && $failures == 0);
 330
 331   return $failures;
 332 }
 333
 334
 335 sub error($) {
 336   my ($err) = @_;
 337   print STDERR "$progname: $err\n";
 338   exit 1;
 339 }
 340
 341 sub usage() {
 342   print STDERR "usage: $progname [--verbose] files ...\n";
 343   exit 1;
 344 }
 345
 346 sub main() {
 347   my @files = ();
 348   while ($#ARGV >= 0) {
 349     $_ = shift @ARGV;
 350     if (m/^--?verbose$/) { $verbose++; }
 351     elsif (m/^-v+$/) { $verbose += length($_)-1; }
 352     elsif (m/^-./) { usage; }
 353     else { push @files, $_; }
 354 #    else { usage; }
 355   }
 356
 357   usage unless ($#files >= 0);
 358   my $failures = 0;
 359   foreach (@files) { $failures += check_config($_); }
 360   exit ($failures);
 361 }
 362
 363 main();