chiark - git - mdw - sw-tools/blob - perl/SW.pm

   1 # -*-perl-*-
   2 #
   3 # $Id: SW.pm,v 1.2 2004/04/08 01:52:19 mdw Exp $
   4 #
   5 # Handling for the `sw' index file
   6 #
   7 # (c) 1999 EBI
   8 #
   9
  10 #----- Licensing notice -----------------------------------------------------
  11 #
  12 # This file is part of sw-tools.
  13 #
  14 # sw-tools is free software; you can redistribute it and/or modify
  15 # it under the terms of the GNU General Public License as published by
  16 # the Free Software Foundation; either version 2 of the License, or
  17 # (at your option) any later version.
  18 #
  19 # sw-tools is distributed in the hope that it will be useful,
  20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 # GNU General Public License for more details.
  23 #
  24 # You should have received a copy of the GNU General Public License
  25 # along with sw-tools; if not, write to the Free Software Foundation,
  26 # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  27
  28 #----- Package preamble -----------------------------------------------------
  29
  30 package SW;
  31
  32 use IO;
  33 use POSIX;
  34
  35 use SWConfig;
  36
  37 #----- Main code ------------------------------------------------------------
  38
  39 # --- @vcmp(a, b)@ ---
  40 #
  41 # Returns < 0, == 0 or > 0 depending on whether a < b, a == b, or a > b, in
  42 # an ordering of version numbers.  A version number is considered to be a
  43 # sequence of digit strings and words, optionally separated by non-word
  44 # characters.  The digit sequences are compared using a numerical ordering.
  45 # The words are compared lexically with the exception that a missing word is
  46 # considered greater than all other strings.
  47
  48 sub vcmp($$) {
  49   my ($a, $b) = @_;
  50   my ($aa, $bb);
  51   my ($ar, $br);
  52
  53   SECTION: while (1) {
  54     if ($a eq $b) { return 0; }
  55
  56     # --- Extract leading digit sequences ---
  57
  58     ($aa, $ar) = $a =~ /^(\d+)(.*)/;
  59     ($bb, $br) = $b =~ /^(\d+)(.*)/;
  60     if ($aa || $bb) {
  61         if ($aa == $bb) { next SECTION; }
  62         else { return $aa <=> $bb; }
  63     }
  64
  65     # --- Extract leading word sequences ---
  66
  67     ($aa, $ar) = $a =~ /^(\w+)(.*)/;
  68     ($bb, $br) = $b =~ /^(\w+)(.*)/;
  69     if (defined($aa) || defined($bb)) {
  70         if ($aa eq $bb) { next SECTION; }
  71         elsif ($aa eq "") { return +1; }
  72         elsif ($bb eq "") { return -1; }
  73         else { return $aa cmp $bb; }
  74     }
  75
  76     # --- Strip leading non-word sequences ---
  77
  78     ($ar) = $a =~ /^\W+(.*)/;
  79     ($br) = $b =~ /^\W+(.*)/;
  80   } continue {
  81     $a = $ar;
  82     $b = $br;
  83   }
  84 }
  85
  86 # --- @read()@ ---
  87 #
  88 # Reads an `sw' index file.  Any EOF condition on the file is cleared before
  89 # reading starts.  This allows multiple reads to pick up any extra appends on
  90 # the file.  Returns the number of items read.
  91
  92 sub read {
  93   my $me = shift;
  94   my $read = 0;
  95
  96   return unless $me->{fh};
  97
  98   seek($me->{fh}, 0, 1);                # Clear EOF flag
  99
 100   while (my $line = $me->{fh}->getline()) {
 101     my %map;
 102
 103     $read++;
 104
 105     chomp($line);
 106     foreach my $f (split(/\s*\;\s*/, $line)) {
 107         %map = (%map, split(/\s*=\s*|\s+/, $f, 2));
 108     }
 109
 110     my $pkg = $map{"package"};
 111     unless ($me->{map}{$pkg} && $me->{map}{$pkg}{"date"} gt $map{"date"}) {
 112         $me->{map}{$pkg} = \%map;
 113         $me->{dirty}{$pkg} = 1;
 114     }
 115   }
 116
 117   return $read;
 118 }
 119
 120 # --- @write()@ ---
 121 #
 122 # Writes an `sw' index file.  The old file is moved out of the way while the
 123 # new one is written a line at a time.  If everyone's playing the game right
 124 # by using append mode, we should be OK.  When the initial write is over, I
 125 # remove the old file, and read and write any more items that were left in
 126 # it.
 127
 128 sub write {
 129   my $me = shift;
 130   my $fh;
 131
 132   unlink($me->{file} . ".old");
 133   rename($me->{file}, $me->{file} . ".old") or return undef;
 134   $fh = IO::File->new($me->{file}, O_APPEND | O_CREAT | O_WRONLY);
 135   $fh->autoflush(1);
 136
 137   my @which = $me->list();
 138
 139   ONE_THERES_A_SISSY: for (;;) {
 140     foreach my $i (@which) {
 141       my $l = "";
 142       foreach my $j (qw(package version maintainer date arch only-arch)) {
 143         $v = $me->{map}{$i}{$j};
 144         $l and $l .= "; ";
 145         $l .= "$j = $v";
 146       }
 147       $fh->print($l . "\n");
 148     }
 149
 150     unlink($me->{file} . ".old");
 151     $me->{dirty} = {};
 152     $me->read() or last ONE_THERES_A_SISSY;
 153     @which =
 154         sort { $me->{map}{$a}{"date"} cmp $me->{map}{$b}{"date"} }
 155              keys(%{$me->{dirty}});
 156   }
 157   return 1;
 158 }
 159
 160 # --- @list()@ ---
 161 #
 162 # Returns a list of package names.
 163
 164 sub list {
 165   my $me = shift;
 166   return sort(keys(%{$me->{map}}));
 167 }
 168
 169 # --- @get(PKG)@ ---
 170 #
 171 # Returns (a reference to) a package's hash entry.
 172
 173 sub get {
 174   my $me = shift;
 175   my $pkg = shift;
 176   return $me->{map}{$pkg};
 177 }
 178
 179 # --- @new([NAME])@ ---
 180 #
 181 # Opens a package index.
 182
 183 sub new {
 184   my $class = shift;
 185   my $file = shift || "$C{prefix}/sw-index";
 186   my $me = bless {}, $class;
 187   my $fh = IO::File->new($file, O_RDONLY);
 188   $me->{file} = $file;
 189   $me->{fh} = $fh;
 190   $me->read();
 191   return $me;
 192 }
 193
 194 #----- That's all, folks ----------------------------------------------------
 195
 196 1;