Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 83 lines (68 sloc) 2.1 KB
#!/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;