0ad/source/errorlist.pl

#!perl -w

use strict;
use warnings;

my (%topgroups, %groups, %types);

my @files = cpp_files('.');

for (@files) {
  open my $f, $_ or die "Error opening file '$_' ($!)";
  while (<$f>) {
    if (/^ERROR_/) {
      if (/^ERROR_GROUP\((.+?)\)/) {
        $topgroups{$1} = 1;
      } elsif (/^ERROR_SUBGROUP\((.+?)\)/) {
        $groups{join '~', split /,\s*/, $1} = 1;
      } elsif (/^ERROR_TYPE\((.+?)\)/) {
        $types{join '~', split /,\s*/, $1} = 1;
      }
    }
  }
}

# Add "PSERROR_Error_InvalidError", so that an error to throw when being
# told to throw an error that doesn't exist exists.
$topgroups{Error} = 1;
$types{'Error~InvalidError'} = 1;

open my $out, '>', 'ps/Errors.cpp' or die "Error opening ps/Errors.cpp ($!)";

print $out <<'.';
// Auto-generated by errorlist.pl - do not edit.

#include "precompiled.h"

#include "Errors.h"

.

for (sort keys %topgroups) {
  print $out "class PSERROR_$_ : public PSERROR {};\n";
}

print $out "\n";

for (sort { $a->[1] cmp $b->[1] } map [$_, do{(my $c=$_)=~s/~/_/;$c} ], keys %groups) {
  my ($base, $name) = split /~/, $_->[0];
  print $out "class PSERROR_${base}_$name : public PSERROR_$base {};\n";
}

print $out "\n";

for (sort { $a->[1] cmp $b->[1] } map [$_, do{(my $c=$_)=~s/~/_/;$c} ], keys %types) {
  my ($base, $name) = split /~/, $_->[0];
  print $out "class PSERROR_${base}_$name : public PSERROR_$base { public: PSERROR_${base}_$name(); };\n";
}

print $out "\n";

# The difficult bit:

=pod

mask
****  PSERROR
0001  PSERROR_          Err1
1***  PSERROR_Sec1
1001  PSERROR_Sec1_     Err1
1002  PSERROR_Sec1_     Err2
1003  PSERROR_Sec1_     Err3
11**  PSERROR_Sec1_Sec1
1101  PSERROR_Sec1_Sec1_Err1
1102  PSERROR_Sec1_Sec1_Err2
2***  PSERROR_Sec2
2001  PSERROR_Sec2_     Err1
            
...so split into three sections (0 if null) plus final code...

=cut

my @sec_codes;
$sec_codes[$_]{''} = 1 for 0..2;

for (keys %types) {
  my (@secs) = split /[~_]/;
  my $err = pop @secs;
  $sec_codes[$_]{$secs[$_] || ''} = 1 for 0..2;
}

for my $n (0..2) {
  @{$sec_codes[$n]}{sort keys %{$sec_codes[$n]}} = 0 .. keys(%{$sec_codes[$n]})-1;
}

my ($last_sec, $last_err) = ('', 0);
for (sort keys %types) {
  my (@secs) = split /[~_]/;
  my $err = pop @secs;
  my $id = join '', map chr $sec_codes[$_]{$secs[$_] || ''}, 0..2;
  if ($id eq $last_sec) {
    $id .= chr(++$last_err);
  } else {
    $last_sec = $id;
    $id .= chr($last_err=1);
  }
  $types{$_} = $id;
}

for (sort keys %types) {
  my ($base, $name) = split /~/;
  print $out "extern const PSRETURN PSRETURN_${base}_${name} = 0x".unpack('H*', $types{$_}).";\n";
}

print $out "\n";

for (sort keys %topgroups) {
  my (@secs) = $_;
  my $id = join '', map chr $sec_codes[$_]{$secs[$_] || ''}, 0..2;
  my $code = unpack 'H*', $id;
  (my $mask = $code) =~ s/(\d\d)/$1+0 ? 'ff' : '00'/ge;
  print $out "extern const PSRETURN MASK__PSRETURN_".join('_', @secs)." = 0x${mask}00;\n";
  print $out "extern const PSRETURN CODE__PSRETURN_".join('_', @secs)." = 0x${code}00;\n";
}

for (sort keys %groups) {
  my (@secs) = split /[_~]/;
  my $id = join '', map chr $sec_codes[$_]{$secs[$_] || ''}, 0..2;
  my $code = unpack 'H*', $id;
  (my $mask = $code) =~ s/(\d\d)/$1+0 ? 'ff' : '00'/ge;
  print $out "extern const PSRETURN MASK__PSRETURN_".join('_', @secs)." = 0x${mask}00;\n";
  print $out "extern const PSRETURN CODE__PSRETURN_".join('_', @secs)." = 0x${code}00;\n";
}

print $out "\n";

for (sort keys %types) {
  my $code = unpack 'H*', $types{$_};
  s/~/_/;
  print $out "extern const PSRETURN MASK__PSRETURN_$_ = 0xffffffff;\n";
  print $out "extern const PSRETURN CODE__PSRETURN_$_ = 0x$code;\n";
}

# End of difficult bit.

print $out "\n";


for (sort keys %types) {
  my ($base, $name) = split /~/;
  print $out qq~PSERROR_${base}_${name}::PSERROR_${base}_${name}() { magic=0x45725221; code=0x~.unpack('H*',$types{$_}).qq~; }\n~;
}

print $out <<".";

const wchar_t* GetErrorString(PSRETURN code)
{
\tswitch (code)
\t{
.

for (sort keys %types) {
  (my $name = $_) =~ s/~/_/;
  print $out qq{\tcase 0x}.unpack('H*',$types{$_}).qq{: return L"$name";\n};
}

print $out <<".";

\tdefault: return L"Unrecognised error";
\t}
}

void ThrowError(PSRETURN code)
{
\tswitch (code)  // Use 'break' in case someone tries to continue from the exception
\t{
.

for (sort keys %types) {
  (my $name = $_) =~ s/~/_/;
  print $out qq{\tcase 0x}.unpack('H*',$types{$_}).qq{: throw PSERROR_$name(); break;\n};
}

print $out <<".";

\tdefault: throw PSERROR_Error_InvalidError(); // Hmm...
\t}
}
.


sub cpp_files {
  opendir my $d, $_[0] or die "Error opening directory '$_[0]' ($!)";
  my @f = readdir $d;
  my @files = map "$_[0]/$_", grep /\.(?:cpp|h)$/, @f;
  push @files, cpp_files("$_[0]/$_") for grep { !/^(?:workspaces|tools|ape|sced)$/ and /^[a-zA-Z0-9]+$/ and -d "$_[0]/$_" } @f;
  return @files;
}