#!/usr/bin/perl -w

#
# mkindexcache
# $Id: mkindexcache,v 1.12 2008/08/08 17:41:14 johnh Exp $
#
# Copyright (C) 1994-2006,2012  Free Software Foundation, Inc.
# Comments to <johnh@isi.edu>.
#
# This file is under the Gnu Public License.
#

sub usage {
    print STDERR <<END;
usage: $0 <index >index.el

Converts a processed index into elisp code to intern
the symbols and font-lock the buffer.
END
    exit 1;
}

require 5.006;  # for IO handling of :locale

# Force unicode for input and output.
# Without this requirement, unicode on the input results in incorrect
# (byte-level, not character-level) values of $seek,
# and since emacs' put-text-property is char-level,
# it gets off.
use open ':locale';   # Now let $ENV{LANG} and $ENV{LC_CTYPE} determine input encoding; previously we forced utf8, but not all are pure.

my(@subjects) = ();
my(@sstart, @send) = ();
my($seek) = 1;

while (<>) {
    if (m@^(.*): \d@) {
        push(@subjects, $1);
	push(@sstart, $seek);
	push(@send, $seek + length($1));
    };
    $seek += length($_);
#    my $l1 = length($_);
#    my $l2;
#    do { use bytes; $l2 = length($_); };
#    print "; $l1 $l2\n";
};

sub round_to_power_of_8 {
    my($n) = @_;
    return 8 ** (length(sprintf("%o", $n)));
}

print ";; auto-generated by mkindexcache\n";
print "(defun notes-index-parse-buffer-cached ()\n";
my($asize) = round_to_power_of_8($#subjects) - 1;
print "  (setq notes-subject-table (make-vector $asize 0))\n";

# output intern'ing code
print "  (mapcar (function (lambda (a) (intern a notes-subject-table))) '(\n";
foreach (@subjects) {
    my($qsubject) = $_;
    $qsubject =~ s/(["\\])/\\$1/g; #"
    print "\t\"$qsubject\"\n";
};
print "    ))\n";

# output font-lock code
print "  (if notes-use-font-lock\n" .
      "    (progn\n" .
      "      (remove-text-properties (point-min) (point-max) '(face nil))\n" .
      "        (mapcar (function (lambda (a)\n" .
      "                            (put-text-property (car a) (cdr a) 'face notes-bold-face)))\n" .
      "                '(\n";
for (0..$#subjects) {
    print "\t\t($sstart[$_] . $send[$_])\n";
};
print "      )))))\n";

exit 0;