#!/usr/bin/env perl
#
# Updates http://cvs.gnome.org/viewcvs/gtk%2B/gtk/gtkimcontextsimple.c from upstream (X.org 6.9/7.0),
# from http://webcvs.freedesktop.org/xorg/lib/X11/nls/en_US.UTF-8/Compose.pre
#
# Name    : compose-sequence-update
# Author  : Simos Xenitellis <simos at gnome dot org>.
# Version : 1.0
#
# Input   : http://webcvs.freedesktop.org/xorg/lib/X11/nls/en_US.UTF-8/Compose.pre
# Output  : http://cvs.gnome.org/viewcvs/gtk%2B/gtk/gtkimcontextsimple.c
#
# Notes   : It downloads Compose.pre from the Internet if not found locally
# Notes   : and creates an updated gtkimcontextsimple.c
#

use strict;

my $line;
my $firstletter;
my @components;
my $i;
my $semicolon_pos;
my $letter;
my $codepoint;
my $codepointhex;
my @entry;
my @gtkimcontext;
my @gtkimcontextsorted;
my @gtkimcontextsorteduniqued;
my $packedline;
my @unpackeda;
my @unpackedb;
my @existingelements;
my @existingseqs;
my $element;
my $previouselement;
my @c;

# Used for reading the GDK key symbols.
my @gdkelements;
my %gdksyms;

# Used for reading the UnicodeData.txt file.
my @unicodeelements;
my %unicodedata;

if ( ! -f "Compose.pre" )
{
        print "Trying to download Compose.pre from\n";
        print "http://webcvs.freedesktop.org/xorg/lib/X11/nls/en_US.UTF-8/Compose.pre: ";
        die "Unable to download Compose.pre from http://webcvs.freedesktop.org/xorg/lib/X11/nls/en_US.UTF-8/Compose.pre\n"
                unless system("wget -q \"http://webcvs.freedesktop.org/xorg/lib/X11/nls/en_US.UTF-8/Compose.pre\"") == 0;
        print " done.\n\n";
}
else
{
        print "We are using an existing Compose.pre (Compose) file found in this directory.\n";
        print "It is assumed that you took care and it is a recent version\n";
        print "as found at http://webcvs.freedesktop.org/*checkout*/xorg/lib/X11/nls/en_US.UTF-8/Compose.pre\n\n";
}


# Source: http://webcvs.freedesktop.org/*checkout*/xorg/lib/X11/nls/en_US.UTF-8/Compose.pre
# or /usr/share/X11/locale/en_US.UTF-8/Compose
# The file can be used verbatim. Comments start with "^XCOMM".
die "Could not open Compose.pre: $!\n" unless open(IN_COMPOSE, "<:utf8", "Compose.pre");

if ( ! -f "gdkkeysyms.h" )
{
        print "It appears you do not have a gdkkeysyms.h file in this directory.\n";
        print "This script requires an updated gdkkeysyms.h in order to run.\n";
        die "See http://bugzilla.gnome.org/show_bug.cgi?id=321896 on how to create it.\n"
}


# Source: gtk+/gdk/gdkkeysyms.h
# or /usr/include/gtk-2.0/gdk/gdkkeysyms.h
die "Could not open file gdkkeysyms.h: $!\n" unless open(IN_GDKKEYSYMS, "<:utf8", "gdkkeysyms.h");

if ( ! -f "UnicodeData.txt" )
{
        print "Trying to download UnicodeData.txt from\n";
        print "http://www.unicode.org/Public/UNIDATA/UnicodeData.txt: ";
        die "Unable to download UnicodeData.txt from http://www.unicode.org/Public/UNIDATA/UnicodeData.txt\n"
                unless system("wget -q \"http://www.unicode.org/Public/UNIDATA/UnicodeData.txt\"") == 0;
        print " done.\n\n";
}
else
{
        print "We are using an existing UnicodeData.txt file found in this directory.\n";
        print "It is assumed that you took care and it is a recent version\n";
        print "as found at http://www.unicode.org/Public/UNIDATA/UnicodeData.txt\n\n";
}


# Source: http://www.unicode.org/Public/UNIDATA/UnicodeData.txt
# or /usr/lib/perl5/5.8.3/unicore/UnicodeData.txt
die "Could not open file UnicodeData.txt: $!\n" unless open(IN_UNICODEDATA, "<:utf8", "UnicodeData.txt");

if ( ! -f "gtkimcontextsimple.c" )
{
        print "It appears you do not have an existing gtkimcontextsimple.c in this directory.\n";
        print "This script requires the gtkimcontextsimple.c that you want to patch.\n";
        print "You can get it from http://cvs.gnome.org/viewcvs/gtk%2B/gtk/gtkimcontextsimple.c\n";
        die "This script will create gtkimcontextsimple.c.UPDATED, the updated version.\n"
}

# Source: gtk+/gtk/gtkimcontextsimple.c
die "Could not open prearranged file gtkimcontextsimple.c: $!\n" unless open(IN_GTKIMCONTEXTSIMPLE, "<:utf8", "gtkimcontextsimple.c");

# if ( -f "gtkimcontextsimple.c.UPDATED" )
# {
#         print "It appears there is already an gtkimcontextsimple.c.UPDATED file in this directory.\n";
#         print "We are going to create this file with the script. Therefore, we cannot continue,\n";
#         die "unless you move the file somewhere else.\n"
# }

# Output file: gtkimcontextsimple.c.UPDATED
die "Could not open output file gtkimcontextsimple.c.UPDATED: $!\n" unless open(OUT_GTKIMCONTEXTSIMPLE_UPDATED, ">:utf8", "gtkimcontextsimple.c.UPDATED"); 

# Output file: multiples.result
die "Could not open output file multiples.result: $!\n" unless open(OUT_MULTIPLES, ">:utf8", "multiples.result");

# Output file: conflicts.result
die "Could not open output file conflicts.result: $!\n" unless open(OUT_CONFLICTS, ">:utf8", "conflicts.result");

keys(%unicodedata) = 20000;
keys(%gdksyms) = 2500;

sub printgtkentrymultiples
{
  my @a = unpack("A100 A100 A100 A100 A100 A50 A150", shift);
  my $destinationfile = shift;

  print OUT_MULTIPLES "  $a[0],\t$a[1],\t$a[2],\t$a[3],\t$a[4],\t$a[5], /* $a[6] */\n";

  return;
}

sub printgtkentryconflicts
{
  my @a = unpack("A100 A100 A100 A100 A100 A50 A150", shift);
  my $destinationfile = shift;

  print OUT_CONFLICTS "  $a[0],\t$a[1],\t$a[2],\t$a[3],\t$a[4],\t$a[5], /* $a[6] */\n";

  return;
}

while (<IN_UNICODEDATA>)
{
	@unicodeelements = split(/;/);
	die "Internal error, no unicodeelements, \$_: $_, \@unicodeelements: @unicodeelements\n" unless @unicodeelements;

	$unicodeelements[1] =~ s/\s+/_/g; 
	$unicodedata{$unicodeelements[0]} = $unicodeelements[1];
	# Example: { "00ED" } = "LATIN_SMALL_LETTER_I_WITH_ACUTE";
}

close IN_UNICODEDATA;

print STDERR "Done reading Unicode Data\n";

while (<IN_GDKKEYSYMS>)
{
	last if (/^#define GDK/);
}

while (<IN_GDKKEYSYMS>)
{
	last if ( /^$/ );

	@gdkelements = split(/\s+/);
	die "Internal error, no gdkelements, \$_: $_, \@gdkelements: @gdkelements\n" unless @gdkelements;

	$gdksyms{$gdkelements[1]} = hex($gdkelements[2]);
	# Example: { "GDK_dead_grave" } = "FE50";
}

$gdksyms{"0"} = "0000";

close IN_GDKKEYSYMS;

print STDERR "Done reading GDK Key Syms\n";

LINE:
while (<IN_COMPOSE>)
{
	next if ( /^XCOMM/ );

	$line = $_;
	$firstletter = substr($line, 0, 1);
	if ( $firstletter eq "#" || $firstletter eq "\n" )
	{
		next LINE;
	}

	# There is one line in the input file that has no space between >:
	$line =~ s/>:/> :/g;

	# There are some lines where keysyms have no whitespace in between, like <dead_acute><Y>
	$line =~ s/></> </g;

	# Some lines begin with spaces, let's remove them first for the split to work.
	$line =~ s/^\s+//g;	

	@components = split(/\s+/, $line);
	die "Internal error, no components, \$_: $_, \@components: @components\n" unless @components;

	$semicolon_pos = 0;
	for ($i = 0; $i < @components; $i++ )
	{
		if ( $components[$i] eq ":" )
		{
			$semicolon_pos = $i;
			last;
		}
	}	
	die "Internal error, no colon, \$_: $_\n" unless $semicolon_pos;

	@entry = ();
	for ( $i = 0; $i < $semicolon_pos; $i++ )
	{
		$_ = $components[$i];
		if ( /^\</ )
		{
			$_ =~ s/^\<(\w*)\>/GDK_$1/g;
			push @entry, $_;
		} 
	}

	for ( $i = $semicolon_pos; $i < 5; $i++ )
	{		
		push @entry, "0";
	}

	# Some keysyms look like <U11ab>. We have to detect them
	# and convert to hex. Else gtk+ won't compile.
	for ( $i = 0; $i < 5; $i++ )
	{
		# If it begins with U (the string has already "GDK_" attached to it),
		if ( index($entry[$i], "GDK_U") == 0 )
		{
			# If it is not just <U>,
			if ( length($entry[$i]) > 5 ) 
			{
				# If it is not something like <Uhorn>,
				if ( hex(substr($entry[$i], 5)) > 0 )
				{
               if ( hex(substr($entry[$i], 5)) > 0xFFFF )
               {
					   $entry[$i] = sprintf("0x100%05X", hex(substr($entry[$i], 5)));
               }
               else 
               {
					   $entry[$i] = sprintf("0x1000%04X", hex(substr($entry[$i], 5)));
               }
				}
			}
		}
	}

	# Now it is time to check if the GDK_* keysyms we guessed
	# actually exists in gdkkeysyms.h
	for ( $i = 0; $i < 5; $i++ )
	{
		# If it begins with "GDK_",
		if ( index($entry[$i], "GDK_") == 0 )
		{
			if ( length($gdksyms{$entry[$i]}) == 0 )
			{
            # Per discussion with Daniel Stone
            # (http://bugzilla.gnome.org/show_bug.cgi?id=321896#c13)
            # we remove any keysyms with 'combining_xxxx'.
            # This takes out 799 compose sequences covering Latin Extended (A or B?)
            # and Ancient Greek.
            #
		      # If it begins with "GDK_",
            if ( $entry[$i] =~ /combining_/ )
            {
               next LINE;
            }
            else
            {
				   print "Could not find $entry[$i], I just got $gdksyms{$entry[$i]}\n";
				   print "A keysym was used in the Compose file but was not found in keysymdef.h\n";
				   print "See https://bugs.freedesktop.org/show_bug.cgi?id=5107\n";
				   die "Fix this first and try again\n";
            }
			}
			else
			{
#				printf "I got %s = 0x%X\n", $entry[$i], $gdksyms{$entry[$i]};
			}
		}
	}

	$letter = $components[$semicolon_pos + 1];
	$letter =~ s/\"//g;

   # We found a quirkiness in Perl; if $a is a Plane 1+ character,
   # ord($a) returns <FFFF, or it chops off the bits over FFFF.
   if ( $components[$semicolon_pos + 2] =~ /^U/ )
   {
	   $codepoint = $components[$semicolon_pos + 2];
      $codepoint =~ s/^U//g;
      $codepoint = sprintf("\U${codepoint}");

      # Some boundary conditions, capturing two cases.
      die if (length($codepoint) < 3);
      if ( length($codepoint) < 4 )
      {
         $codepoint = "0" . $codepoint;
      }

	   $codepointhex = "0x" . $codepoint;
   }
   else
   {
	   $codepoint = sprintf("%04X", ord($letter));
	   $codepointhex = sprintf("0x%04X", ord($letter));
   }

	push @entry, $codepointhex;
	push @entry, $unicodedata{$codepoint};

   if ( ! defined($unicodedata{$codepoint}) )
   {
      die "Cannot find $codepoint in UnicodeData.txt\n";
   }

	$packedline = pack("A100 A100 A100 A100 A100 A50 A150", @entry);
	push @gtkimcontext, $packedline;
	# printf "%s %s %s %s %s : %s  %s\n", $entry[0], $entry[1], $entry[2], $entry[3], $entry[4], $codepointhex, $unicodedata{$codepoint};
	# Example: { GDK_dead_acute, GDK_dead_diaeresis, GDK_Greek_upsilon, 0, 0, 0x03B0, GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS }
}

close IN_COMPOSE;

print STDERR "Done reading Compose.pre Compose file\n";

# The Compose files has either keysyms or unicode values. We need to do
# sorting, so this function allows to compare the two on their value.
sub get_symbolunivalue
{
	my $a = pop;
  
	# If it begins with GDK_ (it's a keysym),
	if ( index($a, "GDK_") == 0 )
	{
#		printf "We got a keysym %s: %d\n", $a, $gdksyms{$a};
		return $gdksyms{$a};
	}
	else
	{
		# It's already a Unicode character, send it over.
#		printf "We got a unichar : %d\n", hex($a);
		return hex($a);
	}
}

sub gtkentrycmp
{
  my @a = unpack("A100 A100 A100 A100 A100 A50 A150", shift);
  my @b = unpack("A100 A100 A100 A100 A100 A50 A150", shift);
  my $verbose = shift;

  for ( $i = 0; $i < 5; $i++ )
  { 
    if ( get_symbolunivalue($a[$i]) <=> get_symbolunivalue($b[$i]) )
    {
      return get_symbolunivalue($a[$i]) <=> get_symbolunivalue($b[$i]);
    }
  }
  
  if ( $a[5] ne $b[5] )
  { 
    if ( $verbose eq "yes" )
    {
      print STDERR "WARNING: Same keysyms for\n1: $a[6] and \n2: $b[6]\n($a[0], $a[1], $a[2], $a[3], $a[4])\n"; 
    }
    return 0;
  }

  return 0;
}

sub gtkentrycmpall
{
  my @a = unpack("A100 A100 A100 A100 A100 A50 A150", shift);
  my @b = unpack("A100 A100 A100 A100 A100 A50 A150", shift);
  my $verbose = shift;

  for ( $i = 0; $i < 5; $i++ )
  {
    # If they are different, comparison is over and return.
    if ( get_symbolunivalue($a[$i]) <=> get_symbolunivalue($b[$i]) )
    {
      return get_symbolunivalue($a[$i]) <=> get_symbolunivalue($b[$i]);
    }
  }

  return $a[5] cmp $b[5];
}

### gtkimcontextsimple.c has some compose sequences that are specific to Win32
#   and do not exist in the X.org Compose file. This stuff has to be added.
#   This script should it at this point.
#
# Let's concatenate the old list with the new one;
### push(@gtkimcontext, @existingseqs);

# Now, let's play. Sorting is ascending.
@gtkimcontextsorted = sort { gtkentrycmpall $a, $b; } @gtkimcontext;

# Ok, also need to uniq this.
$previouselement = "";
foreach $element (@gtkimcontextsorted)
{
	if ( $previouselement eq "" ) 
	{ 
		push @gtkimcontextsorteduniqued, $element;
		$previouselement = $element;
		next; 
	}

	if ( gtkentrycmpall($element, $previouselement) )
	{
	  push @gtkimcontextsorteduniqued, $element;
	}
	else 
	{ 
	  printgtkentrymultiples($element);
	}

	$previouselement = $element;
}

# Now we print same sequences that produce different characters.
$previouselement = "";
foreach $element (@gtkimcontextsorteduniqued)
{
	# Just starting?
	if ( $previouselement eq "" ) 
 	{ 
 		$previouselement = $element;
 		next; 
 	}
  
 	if ( gtkentrycmp($element, $previouselement, "yes") == 0)
 	{
 	  printgtkentryconflicts($element); 
 	  printgtkentryconflicts($previouselement); 
 	}
 
 	$previouselement = $element;
}


while (<IN_GTKIMCONTEXTSIMPLE>)
{
	print OUT_GTKIMCONTEXTSIMPLE_UPDATED $_;
	last if (/^static const guint16 gtk_compose_seqs/);
}

# Final printing of the structure.
foreach $element (@gtkimcontextsorteduniqued)
{
	@c = unpack("A100 A100 A100 A100 A100 A50 A150", $element);	
       print OUT_GTKIMCONTEXTSIMPLE_UPDATED "  $c[0],\t$c[1],\t$c[2],\t$c[3],\t$c[4],\t$c[5], /* $c[6] */\n";
}

while (<IN_GTKIMCONTEXTSIMPLE>)
{
	last if ( /^};$/ );
}

print OUT_GTKIMCONTEXTSIMPLE_UPDATED "};\n";

while (<IN_GTKIMCONTEXTSIMPLE>)
{
	print OUT_GTKIMCONTEXTSIMPLE_UPDATED $_;
}

close IN_GTKIMCONTEXTSIMPLE;

print STDERR "Done writing gtkimcontextsimple.c.UPDATED\n";

close OUT_GTKIMCONTEXTSIMPLE_UPDATED;
close OUT_MULTIPLES;
close OUT_CONFLICTS;

print "\nThe above messages are for debuging purposes\n";

print "\nWe generated the following\n";
if ( ! -z "multiples.result" )
{
print " - multiples.result, when two different sequences produce the same codepoint. This is warning level. \n";  
}
if ( ! -z "conflicts.result" )
{
print " - conflicts.result, when a sequence repeats itself, producing a different codepoint. Due to this, one compose sequence is hidden. This is error level.\n";
}
printf "\nDone.\n";
