0ad/source/tools/errorlist/errorlist.pl

#!/usr/bin/perl -w

++$|;
END { print "\n\nPress enter to exit.\n"; <STDIN> }

use strict;
use warnings;

my ($source, $output);

for (@ARGV) {
  # Note to self: "perl errorlist.pl --source=../../source/i18n --output=../../source/i18n/tests/ps/Errors.cpp"
  if (/[-\/]\?|--\?|--help/) {
    print <<EOH;
$0 parameters:
  --source=../../source               - root directory for source code
  --output=../../source/ps/Errors.cpp - output file to generate
  --help                              - route to enlightenment
EOH
    exit;
  } elsif (/^--source="?(.*?)"?$/) {
    $source = $1;
  } elsif (/^--output="?(.*?)"?$/) {
    $output = $1;
  }
}

$source ||= '../../source';
$output ||= "$source/ps/Errors.cpp";

print "Reading files from $source... ";

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

my @files = cpp_files("$source/");

my $loc = 0;
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;
      }
    }
    ++$loc;
  }
}

# Add commas to number in groups of three
1 while $loc =~ s/(\d+)(\d{3})/$1,$2/;

print "(".@files." files read - $loc lines of code)\n";
print "Generating $output... ";

# 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, '>', "$output" or die "Error opening $output ($!)";

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 { protected: PSERROR_$_(const char* msg); };\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 { protected: PSERROR_${base}_$name(const char* msg); };\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(); PSERROR_${base}_$name(const char* msg); PSRETURN getCode() const; };\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 %topgroups) {
  print $out "PSERROR_${_}::PSERROR_${_}(const char* msg) : PSERROR(msg) { }\n";
}

for (sort keys %groups) {
  my ($base, $name) = split /~/;
  print $out "PSERROR_${base}_${name}::PSERROR_${base}_${name}(const char* msg) : PSERROR_$base(msg) { }\n";
}

print $out "\n";

for (sort keys %types) {
  my ($base, $name) = split /~/;
  print $out "PSERROR_${base}_${name}::PSERROR_${base}_${name}() : PSERROR_$base(NULL) { }\n";
  print $out "PSERROR_${base}_${name}::PSERROR_${base}_${name}(const char* msg) : PSERROR_$base(msg) { }\n";
  print $out "PSRETURN PSERROR_${base}_${name}::getCode() const { return 0x".unpack('H*',$types{$_})."; }\n";
  print $out "\n";
}

print $out <<".";

PSERROR::PSERROR(const char* msg) : m_msg(msg) { }

const char* PSERROR::what() const throw ()
{
	return m_msg ? m_msg : GetErrorString(getCode());
}

const char* GetErrorString(PSRETURN code)
{
	switch (code)
	{
.

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

print $out <<".";

	default: return "Unrecognised error";
	}
}

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

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

print $out <<".";

	default: throw PSERROR_Error_InvalidError(); // Hmm...
	}
}
.

print "Finished.\n";

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)$/ and /^[a-zA-Z0-9]+$/ and -d "$_[0]/$_" } @f;
  return @files;
}