3 # $Id: SW.pm,v 1.1 1999/07/30 18:48:05 mdw Exp $
5 # Handling for the `sw' index file
10 #----- Licensing notice -----------------------------------------------------
12 # This file is part of sw-tools.
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.
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.
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.
28 #----- Revision history -----------------------------------------------------
31 # Revision 1.1 1999/07/30 18:48:05 mdw
32 # Useful bits for the Perl support code.
35 #----- Package preamble -----------------------------------------------------
44 #----- Main code ------------------------------------------------------------
46 # --- @vcmp(a, b)@ ---
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.
61 if ($a eq $b) { return 0; }
63 # --- Extract leading digit sequences ---
65 ($aa, $ar) = $a =~ /^(\d+)(.*)/;
66 ($bb, $br) = $b =~ /^(\d+)(.*)/;
68 if ($aa == $bb) { next SECTION
; }
69 else { return $aa <=> $bb; }
72 # --- Extract leading word sequences ---
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; }
83 # --- Strip leading non-word sequences ---
85 ($ar) = $a =~ /^\W+(.*)/;
86 ($br) = $b =~ /^\W+(.*)/;
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.
103 return unless $me->{fh
};
105 seek($me->{fh
}, 0, 1); # Clear EOF flag
107 while (my $line = $me->{fh
}->getline()) {
113 foreach my $f (split(/\s*\;\s*/, $line)) {
114 %map = (%map, split(/\s*=\s*|\s+/, $f, 2));
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;
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
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
);
144 my @which = $me->list();
146 ONE_THERES_A_SISSY
: for (;;) {
147 foreach my $i (@which) {
149 foreach my $j (qw(package version maintainer date arch only
-arch
)) {
150 $v = $me->{map}{$i}{$j};
154 $fh->print($l . "\n");
157 unlink($me->{file
} . ".old");
159 $me->read() or last ONE_THERES_A_SISSY
;
161 sort { $me->{map}{$a}{"date"} cmp $me->{map}{$b}{"date"} }
162 keys(%{$me->{dirty
}});
169 # Returns a list of package names.
173 return sort(keys(%{$me->{map}}));
178 # Returns (a reference to) a package's hash entry.
183 return $me->{map}{$pkg};
186 # --- @new([NAME])@ ---
188 # Opens a package index.
192 my $file = shift || "$C{prefix}/sw-index";
193 my $me = bless {}, $class;
194 my $fh = IO
::File
->new($file, O_RDONLY
);
201 #----- That's all, folks ----------------------------------------------------