code.delx.au - gnu-emacs-elpa/blob - packages/notes-mode/mkprevnext

   1 #!/usr/bin/perl -w
   2
   3 #
   4 # mkprevnext
   5 # $Id: mkprevnext,v 1.22 2007/02/23 05:15:17 johnh Exp $
   6 #
   7 # Copyright (C) 1994-1996,2012  Free Software Foundation, Inc.
   8 # Comments to <johnh@isi.edu>.
   9 #
  10 # This file is under the Gnu Public License.
  11 #
  12
  13 sub usage {
  14     print STDOUT <<END;
  15 usage: $0 [-X] indexfile [FILE...]
  16         Update the prev and next pointers in [file...]
  17         based on indexfile.
  18
  19         We assume that indexfile is sorted.
  20
  21 Option: -X means read the filesname from stdin rather than the command line.
  22
  23 To update prev/next pointers do:
  24         ./mkprevnext ./index 9?????
  25 END
  26     exit 1
  27 }
  28
  29 require 5.000;
  30
  31
  32 my($files_from_stdin) = undef;
  33 if ($ARGV[0] eq '-X') {
  34     $files_from_stdin = 1;
  35     shift @ARGV;
  36 }
  37 &usage if ($#ARGV < 0);
  38
  39 %direction_delta = split(/ +/, 'prev -1   next 1');
  40
  41
  42 #
  43 # read the index
  44 #
  45 &read_index(shift);
  46
  47 foreach (@ARGV) {
  48     &reindex_file($_);
  49 };
  50 if ($files_from_stdin) {
  51     while (<STDIN>) {
  52         chomp;
  53         &reindex_file($_);
  54     }
  55 };
  56
  57 exit 0;
  58
  59 #
  60 # Read the index file.
  61 # Build links of in $index{"$file#$subject","$prevnext"}.
  62 # Assumes that the index is sorted.
  63 #
  64 sub read_index {
  65     local($indexfile) = @_;
  66     local ($file, $subject);
  67     local (@old_sort_order, @sort_order);
  68     local($filesubject, $prevfilesubject) = ('', '');
  69
  70     if (-z $indexfile) {
  71         warn("$0: aborted.  $indexfile is zero length.\n");
  72         exit 0;
  73     };
  74     open(INDEX,"<$indexfile") || die("Cannot open $indexfile");
  75     binmode INDEX;
  76     ($prevurl, $prevfile, $prevsubject) = ("", "", "");
  77     @sort_order = ("") x 3;
  78     while (<INDEX>) {
  79         chop if (/\n$/);
  80         $url = $_;
  81         ($filehead, $file, $subject) = /^(.*)\/([^#]*)\#(.*)$/;
  82         # Sigh, have to fold things to upper case since sort only
  83         # does that, not to lower case.
  84         $filehead = uc($filehead);
  85         $file = uc($file);
  86         $subject = uc($subject);
  87         $filesubject = "$file#$subject";
  88
  89         # verification
  90         die ("Bad index entry: $_") if (!defined($file) || !defined($subject));
  91         @old_sort_order = @sort_order;
  92         @sort_order = ($subject, $filehead, $file);
  93         foreach $i (0..$#sort_order) {
  94             last if ($sort_order[$i] gt $old_sort_order[$i]);
  95             die ("Index is not in sorted order (entries $i).\n\t$sort_order[$i]\n\t$old_sort_order[$i]\n")
  96                 if ($sort_order[$i] lt $old_sort_order[$i])
  97         };
  98
  99         # Skip repeated entries.
 100         if ($filesubject eq $prevfilesubject) {
 101             $count_i{$filesubject}++;
 102             next;
 103         };
 104
 105         # Record the links.
 106         $url_i{$filesubject} = $url;
 107         if ($prevsubject eq $subject) {
 108             $link_i{$filesubject,'prev'} = $prevfilesubject;
 109             $link_i{$prevfilesubject,'next'} = $filesubject;
 110         } else {
 111             $link_i{$filesubject,'prev'} = 'none';
 112             $link_i{$prevfilesubject,'next'} = 'none';
 113         };
 114         # Count entries per-file.
 115         $count_i{$filesubject} = 1;
 116         ($prevurl, $prevfile, $prevsubject, $prevfilesubject) =
 117             ($url, $file, $subject, $filesubject);
 118     };
 119     # Close the last pointer and hacks for null pointers.
 120     $link_i{$prevfilesubject,'next'} = 'none';
 121     $url_i{'none'} = 'none';
 122     $count_i{'none'} = 1;
 123     close (INDEX);
 124 }
 125
 126
 127 #
 128 # Go through a particular file
 129 # and update its prev/next pointers.
 130 #
 131 sub reindex_file {
 132     local ($fullfile) = @_;
 133     local (@data, $change, $mode, $subject);
 134     local ($mode_lookheader, $mode_expectdash, $mode_expectprev, $mode_expectnext) = (0..99);
 135     local(@olddata);
 136     local (@data, $data, $error);
 137     local ($subject_length, $found_expected_label);
 138     local (%subject_count) = ();
 139
 140     local($file) = ($fullfile);
 141     $file =~ s@.*/([^/]+)@$1@;   # basename
 142
 143     open(FILE,"<$fullfile") || die("Cannot open $file");
 144     @olddata = <FILE>;
 145     close(FILE);
 146     # $file = uc($file);
 147     $change = 0;
 148     $mode = $mode_lookheader;
 149     #
 150     # Scan through the file, looking for headers.
 151     # There is some context senstivity using $mode.
 152     #
 153     foreach (@olddata) {
 154         if ($mode == $mode_lookheader) {
 155             if (!/^(\* .*)$/) {
 156                 # skip simple data
 157                 push (@data, $_);
 158                 next;
 159             } else {
 160                 # header
 161                 $subject = uc($1);
 162                 $filesubject = "$file#$subject";
 163                 push (@data, $_);
 164                 $subject_length = length($_) - 1;
 165                 $subject_count{$subject}++;
 166                 $mode = $mode_expectdash;
 167                 next;
 168             };
 169         } elsif ($mode == $mode_expectdash) {
 170             if (/^\-+$/) {
 171                 # Check and fix dash length.
 172                 if (length($_)-1 != $subject_length) {
 173                     $_ = ("-" x $subject_length) . "\n";
 174                     $change++;
 175                 };
 176                 push (@data, $_);
 177                 $mode = $mode_expectprev;
 178                 next;
 179             } else {
 180                 # warn("warning: subject <$subject> missing dashes in $file.\n") if (!/^\*/);
 181                 push (@data, $_);
 182                 $mode = $mode_lookheader;
 183                 next;
 184             };
 185         } elsif ($mode == $mode_expectprev) {
 186             $found_expected_label = (/^prev: \<(.*)\>$/) ? 1 : 0;
 187             push (@data, &new_link('prev', $file, $subject, $subject_count{$subject}));
 188             $change++ if (!$found_expected_label ||
 189                         ($found_expected_label && $data[$#data] ne $_));
 190             $mode = $mode_expectnext;
 191             if ($found_expected_label) { next; } else { redo; };
 192         } elsif ($mode == $mode_expectnext) {
 193             $found_expected_label = (/^next: \<(.*)\>$/) ? 1 : 0;
 194             push (@data, &new_link('next', $file, $subject, $subject_count{$subject}));
 195             $change++ if (!$found_expected_label ||
 196                         ($found_expected_label && $data[$#data] ne $_));
 197             $mode = $mode_lookheader;
 198             if ($found_expected_label) { next; } else { redo; };
 199         } else {
 200             die ("bad mode: $mode");
 201         };
 202         die("end of loop reached unexpectedly.");
 203     };
 204     close (FILE);
 205
 206     return if (!$change);
 207
 208     warn("Updating file $file.\n") if ($verbose);
 209     warn("   writing backup file ${fullfile}~.\n") if ($verbose);
 210     open(BFILE, ">$fullfile~") || die("Cannot write backup file $fullfile~.\n");
 211     $data = join("", @olddata);
 212     $error = syswrite(BFILE, $data, length($data));
 213     die("Backup file failed.\n") unless ($error = length($data));
 214
 215     open (FILE, ">$fullfile") || goto abort;
 216     $data = join("", @data);
 217     $error = syswrite(FILE, $data, length($data));
 218     goto abort unless ($error == length($data));
 219     close (FILE) || goto abort;
 220     return;
 221
 222 abort:
 223     close (FILE);   # ignore error
 224     warn ("Aborting changes to file $file.\n");
 225     rename("$fullfile~", "$fullfile") ||
 226         die("Could not back-out changes to $file.  Old data saved in $file~.");
 227     return;
 228 }
 229
 230
 231 sub new_link {
 232     local ($direction, $file, $subject, $srcposition) = @_;
 233     local($filesubject) = "$file#$subject";
 234     local($other_count);
 235
 236     # First handle ignorance.
 237     return &format_url($direction,'none')
 238         if (!defined($link_i{$filesubject,$direction}));
 239
 240     # See if we're in the same file.
 241     if (($direction eq 'prev' && $srcposition > 1) ||
 242         ($direction eq 'next' && $srcposition < $count_i{$filesubject})) {
 243
 244         return &format_url($direction, $url_i{$filesubject},
 245             $srcposition + $direction_delta{$direction});
 246
 247     } else {
 248         # In a different file.  Does the other file have multple entries?
 249         $other_count = $count_i{ $link_i{$filesubject,$direction} };
 250         if ($other_count != 1) {
 251
 252             return &format_url($direction,
 253                 $url_i{ $link_i{$filesubject,$direction} },
 254                 ( $direction eq 'prev' ? $other_count : 1));
 255
 256         } else {
 257             # Different file with only one entry.
 258             return &format_url($direction,
 259                 $url_i{ $link_i{$filesubject,$direction} } );
 260         };
 261     };
 262 }
 263
 264 sub format_url {
 265     local($direction, $url, $count) = @_;
 266     $url =~ s/\#\*/#$count*/ if (defined($count));
 267     return "$direction: <$url>\n";
 268 }
 269
 270 ## substutite for "uc", if you want to back-port to perl4.
 271 # sub tolower {
 272 #     local ($s) = @_;
 273 #     $s =~ tr/a-z/A-Z/;
 274 #     return $s;
 275 # }