stylesheets/evergreen_docbook_files/docbook-xsl-1.75.2/fo/pdf2index

   1 #!/usr/bin/perl -- # -*- Perl -*-\r
   2 \r
   3 # this needs some cleanup...\r
   4 \r
   5 my $PSTOTEXT = "pstotext";\r
   6 \r
   7 my $pdf = shift @ARGV;\r
   8 \r
   9 my $index = "";\r
  10 my $inindex = 0;\r
  11 open (F, "$PSTOTEXT $pdf |");\r
  12 while (<F>) {\r
  13     if (/^<\/index/) {\r
  14         $index .= $_;\r
  15         $inindex = 0;\r
  16     }\r
  17     $inindex = 1 if /^<index/;\r
  18 \r
  19     if ($inindex) {\r
  20         $index .= $_ if /^\s*</;\r
  21     }\r
  22 }\r
  23 \r
  24 my $cindex = "";\r
  25 while ($index =~ /^(.*?)((<phrase role=\"pageno\">.*?<\/phrase>\s*)+)/s) {\r
  26     $cindex .= $1;\r
  27     $_ = $2;\r
  28     $index = $'; # '\r
  29 \r
  30     my @pages = m/<phrase role=\"pageno\">.*?<\/phrase>\s*/sg;\r
  31 \r
  32     # Expand ranges\r
  33     if ($#pages >= 0) {\r
  34         my @mpages = ();\r
  35         foreach my $page (@pages) {\r
  36             my $pageno = &pageno($page);\r
  37             if ($pageno =~ /^([0-9]+)[^0-9]([0-9]+)$/) { # funky -\r
  38                 for (my $count = $1; $count <= $2; $count++) {\r
  39                     push (@mpages, "<phrase role=\"$pageno\">$count</phrase>");\r
  40                 }\r
  41             } else {\r
  42                 push (@mpages, $page);\r
  43             }\r
  44         }\r
  45         @pages = sort rangesort @mpages;\r
  46     }\r
  47 \r
  48     # Remove duplicates...\r
  49     if ($#pages > 0) {\r
  50         my @mpages = ();\r
  51         my $current = "";\r
  52         foreach my $page (@pages) {\r
  53             my $pageno = &pageno($page);\r
  54             if ($pageno ne $current) {\r
  55                 push (@mpages, $page);\r
  56                 $current = $pageno;\r
  57             }\r
  58         }\r
  59         @pages = @mpages;\r
  60     }\r
  61 \r
  62     # Collapse ranges...\r
  63     if ($#pages > 1) {\r
  64         my @cpages = ();\r
  65         while (@pages) {\r
  66             my $count = 0;\r
  67             my $len = &rangelen($count, @pages);\r
  68             if ($len <= 2) {\r
  69                 my $page = shift @pages;\r
  70                 push (@cpages, $page);\r
  71             } else {\r
  72                 my $fpage = shift @pages;\r
  73                 my $lpage = "";\r
  74                 while ($len > 1) {\r
  75                     $lpage = shift @pages;\r
  76                     $len--;\r
  77                 }\r
  78                 my $fpno = &pageno($fpage);\r
  79                 my $lpno = &pageno($lpage);\r
  80                 $fpage =~ s/>$fpno</>${fpno}-$lpno</s;\r
  81                 push (@cpages, $fpage);\r
  82             }\r
  83         }\r
  84         @pages = @cpages;\r
  85     }\r
  86 \r
  87     my $page = shift @pages;\r
  88     $page =~ s/\s*$//s;\r
  89     $cindex .= $page;\r
  90     while (@pages) {\r
  91         $page = shift @pages;\r
  92         $page =~ s/\s*$//s;\r
  93         $cindex .= ", $page";\r
  94     }\r
  95 }\r
  96 $cindex .= $index;\r
  97 \r
  98 print "$cindex\n";\r
  99 \r
 100 sub pageno {\r
 101     my $page = shift;\r
 102 \r
 103     $page =~ s/^<phrase.*?>//;\r
 104     $page =~ s/^<link.*?>//;\r
 105 \r
 106     return $1 if $page =~ /^([^<>]+)/;\r
 107     return "?";\r
 108 }\r
 109 \r
 110 sub rangesort {\r
 111     my $apno = &pageno($a);\r
 112     my $bpno = &pageno($b);\r
 113 \r
 114     # Make sure roman pages come before arabic ones, otherwise sort them in order\r
 115     return -1 if ($apno !~ /^\d+/ && $bpno =~ /^\d+/);\r
 116     return  1 if ($apno =~ /^\d+/ && $bpno !~ /^\d+/);\r
 117     return $apno <=> $bpno;\r
 118 }\r
 119 \r
 120 sub rangelen {\r
 121     my $count = shift;\r
 122     my @pages = @_;\r
 123     my $len = 1;\r
 124     my $inrange = 1;\r
 125 \r
 126     my $current = &pageno($pages[$count]);\r
 127     while ($count < $#pages && $inrange) {\r
 128         $count++;\r
 129         my $next = &pageno($pages[$count]);\r
 130         if ($current + 1 eq $next) {\r
 131             $current = $next;\r
 132             $inrange = 1;\r
 133             $len++;\r
 134         } else {\r
 135             $inrange = 0;\r
 136         }\r
 137     }\r
 138 \r
 139     return $len;\r
 140 }\r