lfs-book/stylesheets/lfs-xsl/docbook-xsl-snapshot/fo/pdf2index

#!/usr/bin/perl -- # -*- Perl -*-

# this needs some cleanup...

my $PSTOTEXT = "pstotext";

my $pdf = shift @ARGV;

my $index = "";
my $inindex = 0;
open (F, "$PSTOTEXT $pdf |");
while (<F>) {
    if (/^<\/index/) {
	$index .= $_;
	$inindex = 0;
    }
    $inindex = 1 if /^<index/;

    if ($inindex) {
	$index .= $_ if /^\s*</;
    }
}

my $cindex = "";
while ($index =~ /^(.*?)((<phrase role=\"pageno\">.*?<\/phrase>\s*)+)/s) {
    $cindex .= $1;
    $_ = $2;
    $index = $'; # '

    my @pages = m/<phrase role=\"pageno\">.*?<\/phrase>\s*/sg;

    # Expand ranges
    if ($#pages >= 0) {
	my @mpages = ();
	foreach my $page (@pages) {
	    my $pageno = &pageno($page);
	    if ($pageno =~ /^([0-9]+)[^0-9]([0-9]+)$/) { # funky -
		for (my $count = $1; $count <= $2; $count++) {
		    push (@mpages, "<phrase role=\"$pageno\">$count</phrase>");
		}
	    } else {
		push (@mpages, $page);
	    }
	}
	@pages = sort rangesort @mpages;
    }

    # Remove duplicates...
    if ($#pages > 0) {
	my @mpages = ();
	my $current = "";
	foreach my $page (@pages) {
	    my $pageno = &pageno($page);
	    if ($pageno ne $current) {
		push (@mpages, $page);
		$current = $pageno;
	    }
	}
	@pages = @mpages;
    }

    # Collapse ranges...
    if ($#pages > 1) {
	my @cpages = ();
	while (@pages) {
	    my $count = 0;
	    my $len = &rangelen($count, @pages);
	    if ($len <= 2) {
		my $page = shift @pages;
		push (@cpages, $page);
	    } else {
		my $fpage = shift @pages;
		my $lpage = "";
		while ($len > 1) {
		    $lpage = shift @pages;
		    $len--;
		}
		my $fpno = &pageno($fpage);
		my $lpno = &pageno($lpage);
		$fpage =~ s/>$fpno</>${fpno}-$lpno</s;
		push (@cpages, $fpage);
	    }
	}
	@pages = @cpages;
    }

    my $page = shift @pages;
    $page =~ s/\s*$//s;
    $cindex .= $page;
    while (@pages) {
	$page = shift @pages;
	$page =~ s/\s*$//s;
	$cindex .= ", $page";
    }
}
$cindex .= $index;

print "$cindex\n";

sub pageno {
    my $page = shift;

    $page =~ s/^<phrase.*?>//;
    $page =~ s/^<link.*?>//;

    return $1 if $page =~ /^([^<>]+)/;
    return "?";
}

sub rangesort {
    my $apno = &pageno($a);
    my $bpno = &pageno($b);

    # Make sure roman pages come before arabic ones, otherwise sort them in order
    return -1 if ($apno !~ /^\d+/ && $bpno =~ /^\d+/);
    return  1 if ($apno =~ /^\d+/ && $bpno !~ /^\d+/);
    return $apno <=> $bpno;
}

sub rangelen {
    my $count = shift;
    my @pages = @_;
    my $len = 1;
    my $inrange = 1;

    my $current = &pageno($pages[$count]);
    while ($count < $#pages && $inrange) {
	$count++;
	my $next = &pageno($pages[$count]);
	if ($current + 1 eq $next) {
	    $current = $next;
	    $inrange = 1;
	    $len++;
	} else {
	    $inrange = 0;
	}
    }

    return $len;
}