Useful bits for the Perl support code.

[sw-tools] / perl / SW.pm

# -*-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;