Useful bits for the Perl support code.

diff --git a/perl/SW.pm b/perl/SW.pm
new file mode 100644 (file)
index 0000000..474c621
--- /dev/null
+++ b/perl/SW.pm
@@ -0,0 +1,203 @@
+# -*-perl-*-
+#
+# $Id: SW.pm,v 1.1 1999/07/30 18:48:05 mdw Exp $
+#
+# Handling for the `sw' index file
+#
+# (c) 1999 EBI
+#
+
+#----- Licensing notice -----------------------------------------------------
+#
+# This file is part of sw-tools.
+#
+# sw-tools is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+# 
+# sw-tools is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+# 
+# You should have received a copy of the GNU General Public License
+# along with sw-tools; if not, write to the Free Software Foundation,
+# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+#----- Revision history -----------------------------------------------------
+#
+# $Log: SW.pm,v $
+# Revision 1.1  1999/07/30 18:48:05  mdw
+# Useful bits for the Perl support code.
+#
+
+#----- Package preamble -----------------------------------------------------
+
+package SW;
+
+use IO;
+use POSIX;
+
+use SWConfig;
+
+#----- Main code ------------------------------------------------------------
+
+# --- @vcmp(a, b)@ ---
+#
+# Returns < 0, == 0 or > 0 depending on whether a < b, a == b, or a > b, in
+# an ordering of version numbers.  A version number is considered to be a
+# sequence of digit strings and words, optionally separated by non-word
+# characters.  The digit sequences are compared using a numerical ordering.
+# The words are compared lexically with the exception that a missing word is
+# considered greater than all other strings.
+
+sub vcmp($$) {
+  my ($a, $b) = @_;
+  my ($aa, $bb);
+  my ($ar, $br);
+
+  SECTION: while (1) {
+    if ($a eq $b) { return 0; }
+
+    # --- Extract leading digit sequences ---
+
+    ($aa, $ar) = $a =~ /^(\d+)(.*)/;
+    ($bb, $br) = $b =~ /^(\d+)(.*)/;
+    if ($aa || $bb) {
+       if ($aa == $bb) { next SECTION; }
+       else { return $aa <=> $bb; }
+    }
+
+    # --- Extract leading word sequences ---
+
+    ($aa, $ar) = $a =~ /^(\w+)(.*)/;
+    ($bb, $br) = $b =~ /^(\w+)(.*)/;
+    if (defined($aa) || defined($bb)) {
+       if ($aa eq $bb) { next SECTION; }
+       elsif ($aa eq "") { return +1; }
+       elsif ($bb eq "") { return -1; }
+       else { return $aa cmp $bb; }
+    }
+
+    # --- Strip leading non-word sequences ---
+
+    ($ar) = $a =~ /^\W+(.*)/;
+    ($br) = $b =~ /^\W+(.*)/;
+  } continue {
+    $a = $ar;
+    $b = $br;
+  }
+}
+
+# --- @read()@ ---
+#
+# Reads an `sw' index file.  Any EOF condition on the file is cleared before
+# reading starts.  This allows multiple reads to pick up any extra appends on
+# the file.  Returns the number of items read.
+
+sub read {
+  my $me = shift;
+  my $read = 0;
+
+  return unless $me->{fh};
+
+  seek($me->{fh}, 0, 1);               # Clear EOF flag
+
+  while (my $line = $me->{fh}->getline()) {
+    my %map;
+
+    $read++;
+
+    chomp($line);
+    foreach my $f (split(/\s*\;\s*/, $line)) {
+       %map = (%map, split(/\s*=\s*|\s+/, $f, 2));
+    }
+
+    my $pkg = $map{"package"};
+    unless ($me->{map}{$pkg} && $me->{map}{$pkg}{"date"} gt $map{"date"}) {
+       $me->{map}{$pkg} = \%map;
+       $me->{dirty}{$pkg} = 1;
+    }
+  }
+
+  return $read;
+}
+
+# --- @write()@ ---
+#
+# Writes an `sw' index file.  The old file is moved out of the way while the
+# new one is written a line at a time.  If everyone's playing the game right
+# by using append mode, we should be OK.  When the initial write is over, I
+# remove the old file, and read and write any more items that were left in
+# it. 
+
+sub write {
+  my $me = shift;
+  my $fh;
+
+  unlink($me->{file} . ".old");
+  rename($me->{file}, $me->{file} . ".old") or return undef;
+  $fh = IO::File->new($me->{file}, O_APPEND | O_CREAT | O_WRONLY);
+  $fh->autoflush(1);
+
+  my @which = $me->list();
+
+  ONE_THERES_A_SISSY: for (;;) {
+    foreach my $i (@which) {
+      my $l = "";
+      foreach my $j (qw(package version maintainer date arch only-arch)) {
+       $v = $me->{map}{$i}{$j};
+       $l and $l .= "; ";
+       $l .= "$j = $v";
+      }
+      $fh->print($l . "\n");
+    }
+
+    unlink($me->{file} . ".old");
+    $me->{dirty} = {};
+    $me->read() or last ONE_THERES_A_SISSY;
+    @which = 
+       sort { $me->{map}{$a}{"date"} cmp $me->{map}{$b}{"date"} }
+            keys(%{$me->{dirty}});
+  }
+  return 1;
+}
+
+# --- @list()@ ---
+#
+# Returns a list of package names.
+
+sub list {
+  my $me = shift;
+  return sort(keys(%{$me->{map}}));
+}
+
+# --- @get(PKG)@ ---
+#
+# Returns (a reference to) a package's hash entry.
+
+sub get {
+  my $me = shift;
+  my $pkg = shift;
+  return $me->{map}{$pkg};
+}
+
+# --- @new([NAME])@ ---
+#
+# Opens a package index.
+
+sub new {
+  my $class = shift;
+  my $file = shift || "$C{prefix}/sw-index";
+  my $me = bless {}, $class;
+  my $fh = IO::File->new($file, O_RDONLY);
+  $me->{file} = $file;
+  $me->{fh} = $fh;
+  $me->read();
+  return $me;
+}
+
+#----- That's all, folks ----------------------------------------------------
+
+1;

diff --git a/perl/SWConfig.pm.in b/perl/SWConfig.pm.in
new file mode 100644 (file)
index 0000000..73a9713
--- /dev/null
+++ b/perl/SWConfig.pm.in
@@ -0,0 +1,71 @@
+# -*-perl-*-
+#
+# $Id: SWConfig.pm.in,v 1.1 1999/07/30 18:48:05 mdw Exp $
+#
+# Exports configuration variables
+#
+# (c) 1999 EBI
+#
+
+#----- Licensing notice -----------------------------------------------------
+#
+# This file is part of sw-tools.
+#
+# sw-tools is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+# 
+# sw-tools is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+# 
+# You should have received a copy of the GNU General Public License
+# along with sw-tools; if not, write to the Free Software Foundation,
+# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+#----- Revision history -----------------------------------------------------
+#
+# $Log: SWConfig.pm.in,v $
+# Revision 1.1  1999/07/30 18:48:05  mdw
+# Useful bits for the Perl support code.
+#
+
+#----- Package preamble -----------------------------------------------------
+
+package SWConfig;
+use IO;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(%C);
+
+#----- Configuration variables ----------------------------------------------
+
+%C = ();
+$C{pkg} = '@PACKAGE@';
+$C{version} = '@VERSION@';
+$C{prefix} = '@prefix@';
+$C{datadir} = '@datadir@';
+$C{index} = '${prefix}/sw-index';
+$C{doc} = '${prefix}/doc';
+
+foreach my $k (qw(datadir index doc)) {
+  $C{$k} =~ s/\$\{(\w+)\}/$C{$1}/eg;
+}
+
+#----- Read a configuration file --------------------------------------------
+
+if (my $fh = IO::File->new("$C{datadir}/sw.conf")) {
+  LINE: while (my $line = $fh->getline()) {
+    chomp($line);
+    next LINE if $line =~ /^\s*\#/ || $line =~ /^\s*$/;
+    my ($k, $v) = split(/\s*=\s*|\s+/, $line, 2);
+    $v =~ s/\$\{(\w+)\}/$C{$1}/eg;
+    $C{$k} = $v;
+  }
+}
+
+#----- That's all, folks ----------------------------------------------------
+
+1;