From 87664f815db40f4e97deb340d03dfbc177825ceb Mon Sep 17 00:00:00 2001 From: mdw Date: Fri, 30 Jul 1999 18:48:05 +0000 Subject: [PATCH] Useful bits for the Perl support code. --- perl/SW.pm | 203 ++++++++++++++++++++++++++++++++++++++++++++++++++++ perl/SWConfig.pm.in | 71 ++++++++++++++++++ 2 files changed, 274 insertions(+) create mode 100644 perl/SW.pm create mode 100644 perl/SWConfig.pm.in diff --git a/perl/SW.pm b/perl/SW.pm new file mode 100644 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 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; -- 2.11.0