Added HPMHookGen tool, to re-generate hooks include files

- Slightly reformatted the include files (as produced by the new tool)
- You normally won't need to use the generation tool, but in case you
  do, the software requirements are:
  * A Unix-compatible system (cygwin may work, or may not), capable to
    use the Hercules configure/make build system
  * perl (the perl executable must be in your $PATH)
  * doxygen (the command-line doxygen executable must be in your $PATH)
- The generation tool was developed in collaboration with Ind
  (originally in php, the file here included is a tweaked version ported
  to perl)

Signed-off-by: Haru <haru@dotalux.com>

1 files changed, 568 insertions, 0 deletions

diff --git a/tools/HPMHookGen/HPMHookGen.pl b/tools/HPMHookGen/HPMHookGen.pl
new file mode 100755
index 000000000..5333f3f03
--- /dev/null
+++ b/tools/HPMHookGen/HPMHookGen.pl
@@ -0,0 +1,568 @@
+#!/usr/bin/perl
+
+# Copyright (c) Hercules Dev Team, licensed under GNU GPL.
+# See the LICENSE file
+
+use strict;
+use warnings;
+use XML::Simple;
+
+sub trim($) {
+	my $s = $_[0];
+	$s =~ s/^\s+//; $s =~ s/\s+$//;
+	return $s;
+}
+
+sub parse($$) {
+	my ($p, $d) = @_;
+	$p =~ s/^.*?\)\((.*)\).*$/$1/; # Clean up extra parentheses )(around the arglist)
+
+	# Retrieve return type
+	unless ($d =~ /^(.+)\(\*\s*[a-zA-Z0-9_]+_interface::([^\)]+)\s*\)\(.*\)$/) {
+		print "Error: unable to parse '$d'\n";
+		return {};
+	}
+	my $rt = trim($1);   #return type
+	my $name = trim($2); #function name
+
+	my @args;
+	my ($anonvars, $variadic) = (0, 0);
+	my ($lastvar, $notes) = ('', '');
+
+	$p = ' ' unless $p; # ensure there's at least one character (we don't want a do{} block)
+	while ($p) { # Scan the string for variables
+		my $current = '';
+		my ($paren, $needspace) = (0, 0);
+
+		while ($p) { # Parse tokens
+			$p =~ s|^(?:\s*(?:/\*.*?\*/)?)*||; # strip heading whitespace and c-style comments
+			last unless $p;
+
+			if ($p =~ s/^([a-zA-Z0-9_]+)//) { # Word (variable, type)
+				$current .= ' ' if $needspace;
+				$current .= $1;
+				$needspace = 1;
+				next;
+			}
+			if ($p =~ s/^(,)//) { # Comma
+				last unless $paren; # Argument terminator unless inside parentheses
+				$current .= $1;
+				$needspace = 1;
+				next;
+			}
+			if ($p =~ s/^(\*)//) { # Pointer
+				$current .= ' ' if $needspace;
+				$current .= $1;
+				$needspace = 0;
+				next;
+			}
+			if ($p =~ s/^([\[\].])//) { # Array subscript
+				$current .= $1;
+				$needspace = 0;
+				next;
+			}
+			if ($p =~ s/^(\()//) { # Open parenthesis
+				$current .= ' ' if $needspace;
+				$current .= $1;
+				$needspace = 0;
+				$paren++;
+				next;
+			}
+			if ($p =~ s/^(\))//) { # Closed parenthesis
+				$current .= $1;
+				$needspace = 1;
+				if (!$paren) {
+					$notes .= "\n/* Error: unexpected ')' */";
+					print "Error: unexpected ')' at '$p'\n";
+				} else {
+					$paren--;
+				}
+				next;
+			}
+			$p =~ s/^(.)//; # Any other symbol
+			$notes .= "\n/* Error: Unexpected character '$1' */";
+			print "Error: Unexpected character '$1' at '$p'\n";
+			$current .= $1;
+			$needspace = 0;
+		}
+
+		$current =~ s/^\s+//; $current =~ s/\s+$//g; # trim
+
+		next if (!$current or $current =~ /^void$/); # Skip if empty
+
+		my ($array, $type1, $var, $type2, $indir) = ('', '', '', '', '');
+		if ($current =~ qr/^
+			([\w\s\[\]*]+\()          # Capture words, spaces, array subscripts, up to the first '(' (return type)
+			\s*                       # Skip spaces
+			(\*)                      # Capture the '*' from the function name
+			\s*                       # Skip spaces
+			([\w]*)                   # Capture words (function name)
+			\s*                       # Skip spaces
+			(\)\s*\([\w\s\[\]*,]*\))  # Capture first ')' followed by a '( )' block containing arguments
+			\s*                       # Skip spaces
+			$/x
+		) { # Match a function pointer
+			$type1 = trim($1);
+			$indir = $2;
+			$var = trim($3 // '');
+			$type2 = trim($4);
+		} elsif ($current eq '...') { # Match a '...' variadic argument
+			$type1 = '...';
+			$indir = '';
+			$var = '';
+			$type2 = '';
+		} else { # Match a "regular" variable
+			$type1 = '';
+			while(1) {
+				if ($current =~ /^(const)\s+(.*)$/) { # const modifier
+					$type1 .= "$1 ";
+					$current = $2 // '';
+					next;
+				}
+				if ($current =~ /^((?:un)?signed)\s+((?:char|int|long|short)[*\s]+.*)$/
+				 or $current =~ /^(long|short)\s+((?:int|long)[*\s]+.*)$/
+				) { # signed/unsigned/long/short modifiers
+					$current = $2;
+					$type1 .= "$1 ";
+					next;
+				}
+				if ($current =~ /^(struct|enum)\s+(.*)$/) { # enum and struct names
+					$current = $2 // '';
+					$type1 .= "$1 ";
+				}
+				last; # No other modifiers
+			}
+			if ($current =~ /^\s*(\w+)([*\s]*)(\w*)\s*((?:\[\])?)$/) { # Variable type and name
+				$type1 .= trim($1);
+				$indir = trim($2 // '');
+				$var = trim($3 // '');
+				$array = trim($4 // '');
+				$type2 = '';
+			} else { # Unsupported
+				$notes .= "\n/* Error: Unhandled var type '$current' */";
+				print "Error: Unhandled var type '$current'\n";
+				push(@args, {$current});
+				next;
+			}
+		}
+		unless ($var) {
+			$anonvars++;
+			$var = "p$anonvars";
+		}
+		my ($callvar, $pre_code, $post_code, $dereference, $addressof) = ($var, '', '', '', '');
+		my $indirectionlvl = () = $indir =~ /\*/;
+		if ($type1 eq 'va_list') { # Special handling for argument-list variables
+			$callvar = "${var}___copy";
+			$pre_code = "va_list ${callvar}; va_copy(${callvar}, ${var});";
+			$post_code = "va_end(${callvar});";
+		} elsif ($type1 eq '...') { # Special handling for variadic arguments
+			unless ($lastvar) {
+				$notes .= "\n/* Error: Variadic function with no fixed arguments */";
+				print "Error: Variadic function with no fixed arguments\n";
+				next;
+			}
+			$pre_code = "va_list ${callvar}; va_start(${callvar}, ${lastvar});";
+			$post_code = "va_end(${callvar});";
+			$var = '';
+			$variadic = 1;
+		} elsif (!$indirectionlvl) { # Increase indirection level when necessary
+			$dereference = '*';
+			$addressof = '&';
+		}
+		$indirectionlvl++ if ($array); # Arrays are pointer, no matter how cute you write them
+
+		push(@args, {
+			var     => $var,
+			callvar => $callvar,
+			type    => $type1.$array.$type2,
+			orig    => $type1 eq '...' ? '...' : trim("$type1 $indir$var$array $type2"),
+			indir   => $indirectionlvl,
+			hookf   => $type1 eq '...' ? "va_list ${var}" : trim("$type1 $dereference$indir$var$array $type2"),
+			hookc   => trim("$addressof$callvar"),
+			origc   => trim($callvar),
+			pre     => $pre_code,
+			post    => $post_code,
+		});
+		$lastvar = $var;
+	}
+
+	my $rtmemset = 0;
+	my $rtinit = '';
+	foreach ($rt) { # Decide initialization for the return value
+		my $x = $_;
+		if ($x =~ /^const\s+(.+)$/) { # Strip const modifier
+			$x = $1;
+		}
+		if ($x =~ /\*/g) { # Pointer
+			$rtinit = ' = NULL';
+		} elsif ($x eq 'void') { # void
+			$rtinit = '';
+		} elsif ($x eq 'bool') { # bool
+			$rtinit = ' = false';
+		} elsif ($x =~ /^(?:enum\s+)?damage_lv$/) { # Known enum damage_lv
+			$rtinit = ' = ATK_NONE';
+		} elsif ($x =~ /^(?:enum\s+)?sc_type$/) { # Known enum sc_type
+			$rtinit = ' = SC_NONE';
+		} elsif ($x =~/^(?:enum\s+)?c_op$/) { # Known enum c_op
+			$rtinit = ' = C_NOP';
+		} elsif ($x =~ /^enum\s+BATTLEGROUNDS_QUEUE_ACK$/) { # Known enum BATTLEGROUNDS_QUEUE_ACK
+			$rtinit = ' = BGQA_SUCCESS';
+		} elsif ($x =~ /^enum\s+bl_type$/) { # Known enum bl_type
+			$rtinit = ' = BL_NUL';
+		} elsif ($x =~ /^enum\s+homun_type$/) { # Known enum homun_type
+			$rtinit = ' = HT_INVALID';
+		} elsif ($x =~ /^struct\s+.*$/ or $x eq 'DBData') { # Structs
+			$rtinit = '';
+			$rtmemset = 1;
+		} elsif ($x =~ /^(?:(?:un)?signed\s+)?(?:char|int|long|short)$/
+		      or $x =~ /^(?:long|short)\s+(?:int|long)$/
+		      or $x =~ /^u?int(?:8|16|32|64)$/
+		      or $x eq 'defType'
+		) { # Numeric variables
+			$rtinit = ' = 0';
+		} else { # Anything else
+			$notes .= "\n/* Unknown return type '$rt'. Initializing to '0'. */";
+			print "Unknown return type '$rt'. Initializing to '0'.\n";
+			$rtinit = ' = 0';
+		}
+	}
+
+	return {
+		name     => $name,
+		vname    => $variadic ? "v$name" : $name,
+		type     => $rt,
+		typeinit => $rtinit,
+		memset   => $rtmemset,
+		variadic => $variadic,
+		args     => \@args,
+		notes    => $notes,
+	};
+}
+
+my %key2original;
+my @files = grep { -f } glob 'doxyoutput/xml/*interface*.xml';
+my %ifs;
+my @keys;
+foreach my $file (@files) { # Loop through the xml files
+
+	my $xml = new XML::Simple;
+	my $data = $xml->XMLin($file);
+
+	my $loc = $data->{compounddef}->{location};
+	next unless $loc->{file} =~ /src\/map\//; # We only handle mapserver for the time being
+
+	my $key = $data->{compounddef}->{compoundname};
+	my $original = $key;
+
+	# Some known interfaces with different names
+	if ($key =~ /battleground/) {
+		$key = "bg";
+	} elsif ($key =~ /guild_storage/) {
+		$key = "gstorage";
+	} elsif ($key =~ /homunculus/) {
+		$key = "homun";
+	} elsif ($key =~ /irc_bot/) {
+		$key = "ircbot";
+	} elsif ($key =~ /log_interface/) {
+		$key = "logs";
+	} else {
+		$key =~ s/_interface//;
+	}
+
+	foreach my $v ($data->{compounddef}->{sectiondef}) { # Loop through the sections
+		my $memberdef = $v->{memberdef};
+		foreach my $fk (sort { # Sort the members in declaration order according to what the xml says
+					my $astart = $memberdef->{$a}->{location}->{bodystart} || $memberdef->{$a}->{location}->{line};
+					my $bstart = $memberdef->{$b}->{location}->{bodystart} || $memberdef->{$b}->{location}->{line};
+					$astart <=> $bstart
+				} keys %$memberdef) { # Loop through the members
+			my $f = $memberdef->{$fk};
+
+			my $t = $f->{argsstring};
+			next unless ref $t ne 'HASH' and $t =~ /^[^\[]/; # If it's not a string, or if it starts with an array subscript, we can skip it
+
+			my $if = parse($t, $f->{definition});
+			next unless scalar keys %$if; # If it returns an empty hash reference, an error must've occurred
+
+			# Skip variadic functions, we only allow hooks on their arglist equivalents.
+			# i.e. you can't hook on map->foreachinmap, but you hook on map->vforeachinmap
+			# (foreachinmap is guaranteed to do nothing other than call vforeachinmap)
+			next if ($if->{variadic});
+
+			# Some preprocessing
+			$if->{hname} = "HP_${key}_$if->{name}";
+			$if->{hvname} = "HP_${key}_$if->{vname}";
+
+			$if->{handlerdef} = "$if->{type} $if->{hname}(";
+			$if->{predef} = "$if->{type} (*preHookFunc) (";
+			$if->{postdef} = "$if->{type} (*postHookFunc) (";
+			if ($if->{type} eq 'void') {
+				$if->{precall} = '';
+				$if->{postcall} = '';
+				$if->{origcall} = '';
+			} else {
+				$if->{precall} = "retVal___ = ";
+				$if->{postcall} = "retVal___ = ";
+				$if->{origcall} = "retVal___ = ";
+			}
+			$if->{precall} .= "preHookFunc(";
+			$if->{postcall} .= "postHookFunc(";
+			$if->{origcall} .= "HPMHooks.source.$key.$if->{vname}(";
+			$if->{before} = []; $if->{after} = [];
+
+			my ($i, $j) = (0, 0);
+
+			if ($if->{type} ne 'void') {
+				$j++;
+				$if->{postdef} .= "$if->{type} retVal___";
+				$if->{postcall} .= "retVal___";
+			}
+
+			foreach my $arg (@{ $if->{args} }) {
+				push(@{ $if->{before} }, $arg->{pre}) if ($arg->{pre});
+				push(@{ $if->{after} }, $arg->{post}) if ($arg->{post});
+				if ($i) {
+					$if->{handlerdef} .=  ', ';
+					$if->{predef} .= ', ';
+					$if->{precall} .= ', ';
+					$if->{origcall} .= ', ';
+				}
+				if ($j) {
+					$if->{postdef} .= ', ';
+					$if->{postcall} .= ', ';
+				}
+				$if->{handlerdef} .= $arg->{orig};
+				$if->{predef} .= $arg->{hookf};
+				$if->{precall} .= $arg->{hookc};
+				$if->{postdef} .= $arg->{hookf};
+				$if->{postcall} .= $arg->{hookc};
+				$if->{origcall} .= $arg->{origc};
+				$i++; $j++;
+			}
+
+			if (!$i) {
+				$if->{predef} .= 'void';
+				$if->{handlerdef} .= 'void';
+			}
+			if (!$j) {
+				$if->{postdef} .= 'void';
+			}
+
+			$if->{handlerdef} .= ')';
+			$if->{predef} .= ");";
+			$if->{precall} .= ");";
+			$if->{postdef} .= ");";
+			$if->{postcall} .= ");";
+			$if->{origcall} .= ");";
+
+			$key2original{$key} = $original;
+			$ifs{$key} = [] unless $ifs{$key};
+			push(@{ $ifs{$key} }, $if);
+		}
+	}
+	push(@keys, $key) if $key2original{$key};
+}
+
+# Some interfaces use different names
+my %exportsymbols = map {
+	$_ => &{ sub ($) {
+		return 'battlegrounds' if $_ =~ /^bg$/;
+		return $_;
+	}}($_);
+} @keys;
+
+my ($maxlen, $idx) = (0, 0);
+my $fname;
+$fname = "../../src/plugins/HPMHooking/HPMHooking.HookingPoints.inc";
+open(FH, ">", $fname)
+	or die "cannot open > $fname: $!";
+
+print FH <<"EOF";
+// Copyright (c) Hercules Dev Team, licensed under GNU GPL.
+// See the LICENSE file
+//
+// NOTE: This file was auto-generated and should never be manually edited,
+//       as it will get overwritten.
+
+struct HookingPointData HookingPoints[] = {
+EOF
+
+foreach my $key (@keys) {
+	print FH "/* ".$key." */\n";
+	foreach my $if (@{ $ifs{$key} }) {
+
+		print FH <<"EOF";
+	{ HP_POP($key\->$if->{name}), HP_POP2($if->{hname}), $idx },
+EOF
+
+		$idx += 2;
+		$maxlen = length($key."->".$if->{name}) if( length($key."->".$if->{name}) > $maxlen )
+	}
+}
+print FH <<"EOF";
+};
+
+int HookingPointsLenMax = $maxlen;
+EOF
+close FH;
+
+$fname = "../../src/plugins/HPMHooking/HPMHooking.sources.inc";
+open(FH, ">", $fname)
+	or die "cannot open > $fname: $!";
+
+print FH <<"EOF";
+// Copyright (c) Hercules Dev Team, licensed under GNU GPL.
+// See the LICENSE file
+//
+// NOTE: This file was auto-generated and should never be manually edited,
+//       as it will get overwritten.
+
+EOF
+foreach my $key (@keys) {
+
+	print FH <<"EOF";
+memcpy(&HPMHooks.source.$key, $key, sizeof(struct $key2original{$key}));
+EOF
+}
+close FH;
+
+$fname = "../../src/plugins/HPMHooking/HPMHooking.GetSymbol.inc";
+open(FH, ">", $fname)
+	or die "cannot open > $fname: $!";
+
+print FH <<"EOF";
+// Copyright (c) Hercules Dev Team, licensed under GNU GPL.
+// See the LICENSE file
+//
+// NOTE: This file was auto-generated and should never be manually edited,
+//       as it will get overwritten.
+
+EOF
+foreach my $key (@keys) {
+
+	print FH <<"EOF";
+if( !($key = GET_SYMBOL("$exportsymbols{$key}") ) ) return false;
+EOF
+}
+close FH;
+
+$fname = "../../src/plugins/HPMHooking/HPMHooking.HPMHooksCore.inc";
+open(FH, ">", $fname)
+	or die "cannot open > $fname: $!";
+
+print FH <<"EOF";
+// Copyright (c) Hercules Dev Team, licensed under GNU GPL.
+// See the LICENSE file
+//
+// NOTE: This file was auto-generated and should never be manually edited,
+//       as it will get overwritten.
+
+struct {
+EOF
+
+foreach my $key (@keys) {
+	foreach my $if (@{ $ifs{$key} }) {
+
+		print FH <<"EOF";
+	struct HPMHookPoint *$if->{hname}_pre;
+	struct HPMHookPoint *$if->{hname}_post;
+EOF
+	}
+}
+print FH <<"EOF";
+} list;
+
+struct {
+EOF
+
+foreach my $key (@keys) {
+	foreach my $if (@{ $ifs{$key} }) {
+
+		print FH <<"EOF";
+	int $if->{hname}_pre;
+	int $if->{hname}_post;
+EOF
+	}
+}
+print FH <<"EOF";
+} count;
+
+struct {
+EOF
+
+foreach my $key (@keys) {
+
+	print FH <<"EOF";
+	struct $key2original{$key} $key;
+EOF
+}
+
+print FH <<"EOF";
+} source;
+EOF
+close FH;
+
+$fname = "../../src/plugins/HPMHooking/HPMHooking.Hooks.inc";
+open(FH, ">", $fname)
+	or die "cannot open > $fname: $!";
+
+print FH <<"EOF";
+// Copyright (c) Hercules Dev Team, licensed under GNU GPL.
+// See the LICENSE file
+//
+// NOTE: This file was auto-generated and should never be manually edited,
+//       as it will get overwritten.
+
+EOF
+foreach my $key (@keys) {
+
+	print FH <<"EOF";
+/* $key */
+EOF
+
+	foreach my $if (@{ $ifs{$key} }) {
+		my ($initialization, $beforeblock3, $beforeblock2, $afterblock3, $afterblock2, $retval) = ('', '', '', '', '', '');
+
+		unless ($if->{type} eq 'void') {
+			$initialization  = "\n\t$if->{type} retVal___$if->{typeinit};";
+			$initialization .= "\n\tmemset(&retVal___, '\\0', sizeof($if->{type}));" if $if->{memset};
+		}
+
+		$beforeblock3 .= "\n\t\t\t$_" foreach (@{ $if->{before} });
+		$afterblock3 .= "\n\t\t\t$_" foreach (@{ $if->{after} });
+		$beforeblock2 .= "\n\t\t$_" foreach (@{ $if->{before} });
+		$afterblock2 .= "\n\t\t$_" foreach (@{ $if->{after} });
+		$retval = ' retVal___' unless $if->{type} eq 'void';
+
+		print FH <<"EOF";
+$if->{handlerdef} {$if->{notes}
+	int hIndex = 0;${initialization}
+	if( HPMHooks.count.$if->{hname}_pre ) {
+		$if->{predef}
+		for(hIndex = 0; hIndex < HPMHooks.count.$if->{hname}_pre; hIndex++ ) {$beforeblock3
+			preHookFunc = HPMHooks.list.$if->{hname}_pre[hIndex].func;
+			$if->{precall}$afterblock3
+		}
+		if( *HPMforce_return ) {
+			*HPMforce_return = false;
+			return$retval;
+		}
+	}
+	{$beforeblock2
+		$if->{origcall}$afterblock2
+	}
+	if( HPMHooks.count.$if->{hname}_post ) {
+		$if->{postdef}
+		for(hIndex = 0; hIndex < HPMHooks.count.$if->{hname}_post; hIndex++ ) {$beforeblock3
+			postHookFunc = HPMHooks.list.$if->{hname}_post[hIndex].func;
+			$if->{postcall}$afterblock3
+		}
+	}
+	return$retval;
+}
+EOF
+	}
+}
+
+close FH;
+