source: BOOK/stylesheets/lfs-xsl/docbook-xsl-snapshot/fo/pdf2index@ dae3800

#!/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;
}