mdw@git.distorted.org.uk Git - sw-tools/blob - perl/SW.pm

   1 # -*-perl-*-
   2 #
   3 # $Id: SW.pm,v 1.1 1999/07/30 18:48:05 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 #----- Revision history -----------------------------------------------------
  29 #
  30 # $Log: SW.pm,v $
  31 # Revision 1.1  1999/07/30 18:48:05  mdw
  32 # Useful bits for the Perl support code.
  33 #
  34
  35 #----- Package preamble -----------------------------------------------------
  36
  37 package SW;
  38
  39 use IO;
  40 use POSIX;
  41
  42 use SWConfig;
  43
  44 #----- Main code ------------------------------------------------------------
  45
  46 # --- @vcmp(a, b)@ ---
  47 #
  48 # Returns < 0, == 0 or > 0 depending on whether a < b, a == b, or a > b, in
  49 # an ordering of version numbers.  A version number is considered to be a
  50 # sequence of digit strings and words, optionally separated by non-word
  51 # characters.  The digit sequences are compared using a numerical ordering.
  52 # The words are compared lexically with the exception that a missing word is
  53 # considered greater than all other strings.
  54
  55 sub vcmp($$) {
  56   my ($a, $b) = @_;
  57   my ($aa, $bb);
  58   my ($ar, $br);
  59
  60   SECTION: while (1) {
  61     if ($a eq $b) { return 0; }
  62
  63     # --- Extract leading digit sequences ---
  64
  65     ($aa, $ar) = $a =~ /^(\d+)(.*)/;
  66     ($bb, $br) = $b =~ /^(\d+)(.*)/;
  67     if ($aa || $bb) {
  68         if ($aa == $bb) { next SECTION; }
  69         else { return $aa <=> $bb; }
  70     }
  71
  72     # --- Extract leading word sequences ---
  73
  74     ($aa, $ar) = $a =~ /^(\w+)(.*)/;
  75     ($bb, $br) = $b =~ /^(\w+)(.*)/;
  76     if (defined($aa) || defined($bb)) {
  77         if ($aa eq $bb) { next SECTION; }
  78         elsif ($aa eq "") { return +1; }
  79         elsif ($bb eq "") { return -1; }
  80         else { return $aa cmp $bb; }
  81     }
  82
  83     # --- Strip leading non-word sequences ---
  84
  85     ($ar) = $a =~ /^\W+(.*)/;
  86     ($br) = $b =~ /^\W+(.*)/;
  87   } continue {
  88     $a = $ar;
  89     $b = $br;
  90   }
  91 }
  92
  93 # --- @read()@ ---
  94 #
  95 # Reads an `sw' index file.  Any EOF condition on the file is cleared before
  96 # reading starts.  This allows multiple reads to pick up any extra appends on
  97 # the file.  Returns the number of items read.
  98
  99 sub read {
 100   my $me = shift;
 101   my $read = 0;
 102
 103   return unless $me->{fh};
 104
 105   seek($me->{fh}, 0, 1);                # Clear EOF flag
 106
 107   while (my $line = $me->{fh}->getline()) {
 108     my %map;
 109
 110     $read++;
 111
 112     chomp($line);
 113     foreach my $f (split(/\s*\;\s*/, $line)) {
 114         %map = (%map, split(/\s*=\s*|\s+/, $f, 2));
 115     }
 116
 117     my $pkg = $map{"package"};
 118     unless ($me->{map}{$pkg} && $me->{map}{$pkg}{"date"} gt $map{"date"}) {
 119         $me->{map}{$pkg} = \%map;
 120         $me->{dirty}{$pkg} = 1;
 121     }
 122   }
 123
 124   return $read;
 125 }
 126
 127 # --- @write()@ ---
 128 #
 129 # Writes an `sw' index file.  The old file is moved out of the way while the
 130 # new one is written a line at a time.  If everyone's playing the game right
 131 # by using append mode, we should be OK.  When the initial write is over, I
 132 # remove the old file, and read and write any more items that were left in
 133 # it.
 134
 135 sub write {
 136   my $me = shift;
 137   my $fh;
 138
 139   unlink($me->{file} . ".old");
 140   rename($me->{file}, $me->{file} . ".old") or return undef;
 141   $fh = IO::File->new($me->{file}, O_APPEND | O_CREAT | O_WRONLY);
 142   $fh->autoflush(1);
 143
 144   my @which = $me->list();
 145
 146   ONE_THERES_A_SISSY: for (;;) {
 147     foreach my $i (@which) {
 148       my $l = "";
 149       foreach my $j (qw(package version maintainer date arch only-arch)) {
 150         $v = $me->{map}{$i}{$j};
 151         $l and $l .= "; ";
 152         $l .= "$j = $v";
 153       }
 154       $fh->print($l . "\n");
 155     }
 156
 157     unlink($me->{file} . ".old");
 158     $me->{dirty} = {};
 159     $me->read() or last ONE_THERES_A_SISSY;
 160     @which =
 161         sort { $me->{map}{$a}{"date"} cmp $me->{map}{$b}{"date"} }
 162              keys(%{$me->{dirty}});
 163   }
 164   return 1;
 165 }
 166
 167 # --- @list()@ ---
 168 #
 169 # Returns a list of package names.
 170
 171 sub list {
 172   my $me = shift;
 173   return sort(keys(%{$me->{map}}));
 174 }
 175
 176 # --- @get(PKG)@ ---
 177 #
 178 # Returns (a reference to) a package's hash entry.
 179
 180 sub get {
 181   my $me = shift;
 182   my $pkg = shift;
 183   return $me->{map}{$pkg};
 184 }
 185
 186 # --- @new([NAME])@ ---
 187 #
 188 # Opens a package index.
 189
 190 sub new {
 191   my $class = shift;
 192   my $file = shift || "$C{prefix}/sw-index";
 193   my $me = bless {}, $class;
 194   my $fh = IO::File->new($file, O_RDONLY);
 195   $me->{file} = $file;
 196   $me->{fh} = $fh;
 197   $me->read();
 198   return $me;
 199 }
 200
 201 #----- That's all, folks ----------------------------------------------------
 202
 203 1;