Subversion Repositories

?revision_form?Rev ?revision_input??revision_submit??revision_endform?

Rev 1 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
1 magnus 1
package DebPool::Packages;
2
 
3
###
4
#
5
# DebPool::Packages - Module for handling package metadata
6
#
7
# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
8
# 
9
# Redistribution and use in source and binary forms, with or without
10
# modification, are permitted provided that the following conditions
11
# are met:
12
# 1. Redistributions of source code must retain the above copyright
13
#    notice, this list of conditions and the following disclaimer.
14
# 2. Redistributions in binary form must reproduce the above copyright
15
#    notice, this list of conditions and the following disclaimer in the
16
#    documentation and/or other materials provided with the distribution.
17
# 3. Neither the name of the Author nor the names of any contributors
18
#    may be used to endorse or promote products derived from this software
19
#    without specific prior written permission.
20
# 
21
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
22
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24
# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
25
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
26
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
27
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
29
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
30
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
31
# SUCH DAMAGE.
32
#
33
# $Id: Packages.pm 70 2006-06-26 20:44:57Z joel $
34
#
35
###
36
 
37
# We use 'our', so we must have at least Perl 5.6
38
 
39
require 5.006_000;
40
 
41
# Always good ideas.
42
 
43
use strict;
44
use warnings;
45
 
46
use POSIX; # WEXITSTATUS
47
use File::Temp qw(tempfile);
48
 
49
### Module setup
50
 
51
BEGIN {
52
    use Exporter ();
53
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
54
 
55
    # Version checking
56
    $VERSION = '0.1.5';
57
 
58
    @ISA = qw(Exporter);
59
 
60
    @EXPORT = qw(
61
    );
62
 
63
    @EXPORT_OK = qw(
64
        &Allow_Version
65
        &Audit_Package
66
        &Generate_List
67
        &Generate_Package
68
        &Generate_Source
69
        &Guess_Section
70
        &Install_List
71
        &Install_Package
72
        &Parse_Changes
73
        &Parse_DSC
74
        &Reject_Package
75
        &Verify_MD5
76
    );
77
 
78
    %EXPORT_TAGS = (
79
        'functions' => [qw(&Allow_Version &Audit_Package &Generate_List
80
                           &Generate_Package &Generate_Source &Guess_Section
81
                           &Install_List &Install_Package &Parse_Changes
82
                           &Parse_DSC &Reject_Package &Verify_MD5)],
83
        'vars' => [qw()],
84
    );
85
}
86
 
87
### Exported package globals
88
 
89
# None
90
 
91
### Non-exported package globals
92
 
93
# Thread-safe? What's that? Package global error value. We don't export
94
# this directly, because it would conflict with other modules.
95
 
96
our($Error);
97
 
98
# Fields (other than package relationships) from dpkg --info that we
99
# actually care about in some fashion.
100
 
101
my(@Info_Fields) = (
102
#    'Package',
103
    'Priority',
104
    'Section',
105
    'Installed-Size',
106
#    'Maintainer',
107
    'Architecture',
108
#    'Version',
109
    'Essential',
110
);
111
 
112
# Package relationship fieldnames.
113
 
114
my(@Relationship_Fields) = (
115
    'Pre-Depends',
116
    'Depends',
117
    'Provides',
118
    'Conflicts',
119
    'Recommends',
120
    'Suggests',
121
    'Enhances',
122
    'Replaces',
123
);
124
 
125
# Normal fields potentially found in .changes files
126
 
127
my(%Changes_Fields) = (
128
    'Format' => 'string',
129
    'Date' => 'string',
130
    'Source' => 'string',
131
    'Binary' => 'space_array',
132
    'Architecture' => 'space_array',
133
    'Version' => 'string',
134
    'Distribution' => 'space_array',
135
    'Urgency' => 'string',
136
    'Maintainer' => 'string',
137
    'Changed-By' => 'string',
138
    'Closes' => 'space_array',
139
);
140
 
141
# Normal fields potentially found in .dsc files
142
 
143
my(%DSC_Fields) = (
144
    'Format' => 'string',
145
    'Source' => 'string',
146
    'Version' => 'string',
147
    'Binary' => 'comma_array',
148
    'Maintainer' => 'string',
149
    'Architecture' => 'space_array',
150
    'Standards-Version' => 'string',
151
    'Build-Depends' => 'comma_array',
152
    'Build-Depends-Indep' => 'comma_array',
153
);
154
 
155
### File lexicals
156
 
157
# None
158
 
159
### Constant functions
160
 
161
# None
162
 
163
### Meaningful functions
164
 
165
# Allow_Version($package, $version, $distribution)
166
#
167
# Decide, based on version comparison and config options, whether $version
168
# is an acceptable version for $package in $distribution. Returns 1 if the
169
# version is acceptable, 0 if it is not, and undef (and sets $Error) in the
170
# case of an error.
171
 
172
sub Allow_Version {
173
    use DebPool::Config qw(:vars);
174
    use DebPool::DB qw(:functions);
175
    use DebPool::Logging qw(:functions :facility :level);
176
 
177
    my($package, $version, $distribution) = @_;
178
    my($old_version) = Get_Version($distribution, $package, 'meta');
179
 
180
    # If we permit rollback, any version is valid.
181
 
182
    if ($Options{'rollback'}) {
183
        return 1;
184
    }
185
 
186
    # If we don't have an old version, anything is acceptable.
187
 
188
    if (!defined($old_version)) {
189
        return 1;
190
    }
191
 
192
    my($dpkg_bin) = '/usr/bin/dpkg';
193
    my(@args) = ('--compare-versions', $version, 'gt', $old_version);
194
 
195
    my($sysret) = WEXITSTATUS(system($dpkg_bin, @args));
196
 
197
    if (0 != $sysret) { # DPKG says no go.
198
        my($msg) = "Version comparison for '$package': proposed version for ";
199
        $msg .= "$distribution ($version) is not greater than current ";
200
        $msg .= "version ($old_version)";
201
        Log_Message($msg, LOG_GENERAL, LOG_DEBUG);
202
 
203
        return 0;
204
    }
205
 
206
    return 1;
207
}
208
 
209
# Parse_Changes($changes_filename)
210
#
211
# Parses the changes file found at $changes_filename (which should be a
212
# fully qualified path and filename), and returns a hashref pointing to a
213
# Changes hash. Returns undef in the case of a failure (and sets $Error).
214
 
215
# Changes Hash format:
216
# {
217
#   'Architecture' => \@Architectures
218
#   'Binary' => \@Binaries
219
#   'Changed-By' => Changed-By
220
#   'Changes' => \@Changes lines
221
#   'Closes' => \@Bugs
222
#   'Description' => Description
223
#   'Files' => \@\%File Hashes
224
#   'Date' => RFC 822 timestamp
225
#   'Distribution' => \@Distributions
226
#   'Maintainer' => Maintainer
227
#   'Source' => Source
228
#   'Urgency' => Urgency
229
#   'Version' => Version
230
# }
231
 
232
# File Hash format:
233
# {
234
#   'Filename' => Filename (leaf node only)
235
#   'MD5Sum' => File MD5Sum
236
#   'Priority' => Requested archive priority
237
#   'Section' => Requested archive section
238
#   'Size' => File size (in bytes)
239
# }
240
 
241
sub Parse_Changes {
242
    use DebPool::GnuPG qw(:functions);
243
    use DebPool::Logging qw(:functions :facility :level);
244
 
245
    my($file) = @_;
246
    my(%result);
247
 
248
    # Read in the entire Changes file, stripping GPG encoding if we find
249
    # it. It should be small, this is fine.
250
 
251
    if (!open(CHANGES, '<', $file)) {
252
        $Error = "Couldn't open changes file '$file': $!";
253
        return undef;
254
    }
255
 
256
    my(@changes) = <CHANGES>;
257
    chomp(@changes);
258
    @changes = Strip_GPG(@changes);
259
    close(CHANGES);
260
 
261
    # Go through each of the primary fields, stuffing it into the result
262
    # hash if we find it.
263
 
264
    my($field);
265
    foreach $field (keys(%Changes_Fields)) {
266
        my(@lines) = grep(/^${field}:\s+/, @changes);
267
        if (-1 == $#lines) { # No match
268
            next;
269
        } elsif (0 < $#lines) { # Multiple matches
270
            Log_Message("Duplicate entries for field '$field'",
271
                        LOG_PARSE, LOG_WARNING);
272
        }
273
 
274
        $lines[0] =~ s/^${field}:\s+//;
275
 
276
        if ('string' eq $Changes_Fields{$field}) {
277
            $result{$field} = $lines[0];
278
        } elsif ('space_array' eq $Changes_Fields{$field}) {
279
            my(@array) = split(/\s+/, $lines[0]);
280
            $result{$field} = \@array;
281
        } elsif ('comma_array' eq $Changes_Fields{$field}) {
282
            my(@array) = split(/\s+,\s+/, $lines[0]);
283
            $result{$field} = \@array;
284
        }
285
    }
286
 
287
    # Now that we should have it, check to make sure we have a Format
288
    # header, and that it's format 1.7 (the only thing we grok).
289
 
290
    if (!defined($result{'Format'})) {
291
        Log_Message("No Format header found in changes file '$file'",
292
                    LOG_PARSE, LOG_ERROR);
293
        $Error = 'No Format header found';
294
        return undef;
295
    } elsif ('1.7' ne $result{'Format'}) {
296
        Log_Message("Unrecognized Format version '$result{'Format'}'",
297
                    LOG_PARSE, LOG_ERROR);
298
        $Error = 'Unrecognized Format version';
299
        return undef;
300
    }
301
 
302
    # Special case: Description. One-line entry, immediately after a line
303
    # with '^Description:'.
304
 
305
    my($count);
306
 
307
    for $count (0..$#changes) {
308
        if ($changes[$count] =~ m/^Description:/) {
309
            $result{'Description'} = $changes[$count+1];
310
        }
311
    }
312
 
313
    # Special case: Changes. Multi-line entry, starts one line after
314
    # '^Changes:', goes until we hit the Files header.
315
 
316
    my($found) = 0;
317
    my(@changelines);
318
 
319
    for $count (0..$#changes) {
320
        if ($found) {
321
            if ($changes[$count] =~ m/^Files:/) {
322
                $found = 0;
323
            } else {
324
                push(@changelines, $changes[$count]);
325
            }
326
        } else {
327
            if ($changes[$count] =~ m/^Changes:/) {
328
                $found = 1;
329
            }
330
        }
331
    }
332
 
333
    $result{'Changes'} = \@changelines;
334
 
335
    # The Files section is a special case. It starts on the line after the
336
    # 'Files:' header, and goes until we hit a blank line, or the end of
337
    # the data.
338
 
339
    my(@files);
340
 
341
    for $count (0..$#changes) {
342
        if ($found) {
343
            if ($changes[$count] =~ m/^\s*$/) { # Blank line
344
                $found = 0; # No longer in Files
345
            } elsif ($changes[$count] =~ m/\s*([[:xdigit:]]+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
346
                my($md5, $size, $sec, $pri, $file) = ($1, $2, $3, $4, $5);
347
                push(@files, {
348
                    'Filename' => $file,
349
                    'MD5Sum' => $md5,
350
                    'Priority' => $pri,
351
                    'Section' => $sec,
352
                    'Size' => $size,
353
                });
354
            } else { # What's this doing here?
355
                my($msg) = 'Unrecognized data in Files section of changes file';
356
                $msg .= " '$file'";
357
                Log_Message($msg, LOG_PARSE, LOG_WARNING);
358
            }
359
        } else {
360
            if ($changes[$count] =~ m/^Files:/) {
361
                $found = 1;
362
            }
363
        }
364
    }
365
 
366
    $result{'Files'} = \@files;
367
 
368
    return \%result;
369
}
370
 
371
# Parse_DSC($dsc_filename)
372
#
373
# Parses the dsc file found at $dsc_filename (which should be a fully
374
# qualified path and filename), and returns a hashref pointing to a DSC
375
# hash. Returns undef in the case of a failure (and sets $Error).
376
 
377
# DSC Hash format:
378
# {
379
#   'Format' => Format
380
#   'Source' => Source
381
#   'Binary' => \@Binaries
382
#   'Maintainer' => Maintainer
383
#   'Architecture' => \@Architectures
384
#   'Standards-Version' => Standards-Version
385
#   'Build-Depends' => Build-Depends
386
#   'Build-Depends-Indep' => Build-Depends-Indep
387
#   'Files' => \@\%Filehash
388
# }
389
 
390
# File Hash format:
391
# {
392
#   'Filename' => Filename (leaf node only)
393
#   'MD5Sum' => File MD5Sum
394
#   'Size' => File size (in bytes)
395
# }
396
 
397
sub Parse_DSC {
398
    use DebPool::GnuPG qw(:functions);
399
    use DebPool::Logging qw(:functions :facility :level);
400
 
401
    my($file) = @_;
402
    my(%result);
403
 
404
    # Read in the entire DSC file, stripping GPG encoding if we find it. It
405
    # should be small, this is fine.
406
 
407
    if (!open(DSC, '<', $file)) {
408
        $Error = "Couldn't open dsc file '$file': $!";
409
        return undef;
410
    }
411
 
412
    my(@dsc) = <DSC>;
413
    chomp(@dsc);
414
    @dsc = Strip_GPG(@dsc);
415
    close(DSC);
416
 
417
    # Go through each of the primary fields, stuffing it into the result
418
    # hash if we find it.
419
 
420
    my($field);
421
    foreach $field (keys(%DSC_Fields)) {
422
        my(@lines) = grep(/^${field}:\s+/, @dsc);
423
        if (-1 == $#lines) { # No match
424
            next;
425
        } elsif (0 < $#lines) { # Multiple matches
426
            Log_Message("Duplicate entries for field '$field'",
427
                        LOG_PARSE, LOG_WARNING);
428
        }
429
 
430
        $lines[0] =~ s/^${field}:\s+//;
431
 
432
        if ('string' eq $DSC_Fields{$field}) {
433
            $result{$field} = $lines[0];
434
        } elsif ('space_array' eq $DSC_Fields{$field}) {
435
            my(@array) = split(/\s+/, $lines[0]);
436
            $result{$field} = \@array;
437
        } elsif ('comma_array' eq $DSC_Fields{$field}) {
438
            my(@array) = split(/\s+,\s+/, $lines[0]);
439
            $result{$field} = \@array;
440
        }
441
    }
442
 
443
    # Now that we should have it, check to make sure we have a Format
444
    # header, and that it's format 1.0 (the only thing we grok).
445
 
446
    if (!defined($result{'Format'})) {
447
        Log_Message("No Format header found in dsc file '$file'",
448
                    LOG_PARSE, LOG_ERROR);
449
        $Error = 'No Format header found';
450
        return undef;
451
    } elsif ('1.0' ne $result{'Format'}) {
452
        Log_Message("Unrecognized Format version '$result{'Format'}'",
453
                    LOG_PARSE, LOG_ERROR);
454
        $Error = 'Unrecognized Format version';
455
        return undef;
456
    }
457
 
458
    # The Files section is a special case. It starts on the line after the
459
    # 'Files:' header, and goes until we hit a blank line, or the end of
460
    # the data.
461
 
462
    # In fact, it's even more special than that; it includes, first, an entry
463
    # for the DSC file itself...
464
 
465
    my($count);
466
    my($found) = 0;
467
    my(@files);
468
 
469
    my(@temp) = split(/\//, $file);
470
    my($dsc_leaf) = pop(@temp);
471
 
472
    my($cmd_result) = `/usr/bin/md5sum $file`;
473
    $cmd_result =~ m/^([[:xdigit:]]+)\s+/;
474
    my($dsc_md5) = $1;
475
 
476
    my(@stat) = stat($file);
477
    if (!@stat) {
478
        $Error = "Couldn't stat DSC file '$file'";
479
        return undef;
480
    }
481
    my($dsc_size) = $stat[7];
482
 
483
    push(@files, {
484
        'Filename' => $dsc_leaf,
485
        'MD5Sum' => $dsc_md5,
486
        'Size' => $dsc_size,
487
    });
488
 
489
    for $count (0..$#dsc) {
490
        if ($found) {
491
            if ($dsc[$count] =~ m/^\s*$/) { # Blank line
492
                $found = 0; # No longer in Files
493
            } elsif ($dsc[$count] =~ m/\s*([[:xdigit:]]+)\s+(\d+)\s+(\S+)/) {
494
                my($md5, $size, $file) = ($1, $2, $3);
495
                push(@files, {
496
                    'Filename' => $file,
497
                    'MD5Sum' => $md5,
498
                    'Size' => $size,
499
                });
500
            } else { # What's this doing here?
501
                my($msg) = 'Unrecognized data in Files section of dsc file';
502
                $msg .= " '$file'";
503
                Log_Message($msg, LOG_PARSE, LOG_WARNING);
504
            }
505
        } else {
506
            if ($dsc[$count] =~ m/^Files:/) {
507
                $found = 1;
508
            }
509
        }
510
    }
511
 
512
    $result{'Files'} = \@files;
513
 
514
    return \%result;
515
}
516
 
517
# Generate_List($distribution, $section, $arch)
518
#
519
# Generates a Packages (or Sources) file for the given distribution,
520
# section, and architecture (with 'source' being a special value for
521
# Sources). Returns the filename of the generated file on success, or undef
522
# (and sets $Error) on failure. Note that requests for an 'all' list are
523
# ignored - however, every non-source arch gets 'all' files.
524
 
525
sub Generate_List {
526
    use DebPool::Config qw(:vars);
527
    use DebPool::DB qw(:functions :vars);
528
    use DebPool::Dirs qw(:functions);
529
 
530
    my($distribution, $section, $arch) = @_;
531
 
532
    my(%packages);
533
 
534
    if ('all' eq $arch) {
535
        $Error = "No point in generating Packages file for binary-all";
536
        return undef;
537
    }
538
 
539
    my(@sources) = grep($ComponentDB{$distribution}->{$_} eq $section,
540
                        keys(%{$ComponentDB{$distribution}}));
541
 
542
    my($tmpfile_handle, $tmpfile_name) = tempfile();
543
 
544
    my($source);
545
 
546
    # Dump the data from pool/*/*/pkg_ver.{package,source} into the list.
547
 
548
    # FIXME: This needs to be refactored. Needs it pretty badly, in fact.
549
 
550
    if ('source' eq $arch) {
551
        foreach $source (@sources) {
552
            my($pool) = join('/',
553
                ($Options{'pool_dir'}, PoolDir($source, $section), $source));
554
            my($version) = Get_Version($distribution, $source, 'meta');
555
            my($target) = "$pool/${source}_" . Strip_Epoch($version);
556
            $target .= '.source';
557
 
558
            # Source files aren't always present.
559
            next if (!open(SRC, '<', "$target"));
560
 
561
            print $tmpfile_handle <SRC>;
562
            close(SRC);
563
        }
564
    } else {
565
        foreach $source (@sources) {
566
            my($pool) = join('/',
567
                ($Options{'pool_dir'}, PoolDir($source, $section), $source));
568
            my($version) = Get_Version($distribution, $source, 'meta');
569
            my($target) = "$pool/${source}_" . Strip_Epoch($version);
570
            $target .= '.package';
571
 
572
            if (!open(PKG, '<', "$target")) {
573
                my($msg) = "Skipping package entry for all packages from ";
574
                $msg .= "${source}: couldn't open '$target' for reading: $!";
575
 
576
                Log_Message($msg, LOG_GENERAL, LOG_ERROR);
577
                next;
578
            }
579
 
580
            # Playing around with the record separator ($/) to make this
581
            # easier.
582
 
583
            my($backup_RS) = $/;
584
            $/ = "";
585
 
586
            my(@entries) = <PKG>;
587
            close(PKG);
588
 
589
            $/ = $backup_RS;
590
 
591
            # Pare it down to the relevant entries, and print those out.
592
 
593
            @entries = grep(/\nArchitecture: ($arch|all)\n/, @entries);
594
            print $tmpfile_handle @entries;
595
        }
596
    }
597
 
598
    close($tmpfile_handle);
599
 
600
    return $tmpfile_name;
601
}
602
 
603
# Install_Package($changes, $Changes_hashref, $DSC, $DSC_hashref, \@distributions)
604
#
605
# Install all of the package files for $Changes_hashref (which should
606
# be a Parse_Changes result hash) into the pool directory, and install
607
# the file in $changes to the installed directory. Also generates (and
608
# installes) .package and .source meta-data files. It also updates the
609
# Version database for the listed distributions. Returns 1 if successful, 0
610
# if not (and sets $Error).
611
 
612
sub Install_Package {
613
    use DebPool::Config qw(:vars);
614
    use DebPool::Dirs qw(:functions);
615
    use DebPool::DB qw(:functions :vars);
616
    use DebPool::Util qw(:functions);
617
 
618
    my($changes, $chg_hashref, $dsc, $dsc_hashref, $distributions) = @_;
619
 
620
    my($incoming_dir) = $Options{'incoming_dir'};
621
    my($installed_dir) = $Options{'installed_dir'};
622
    my($pool_dir) = $Options{'pool_dir'};
623
 
624
    my($pkg_name) = $chg_hashref->{'Source'};
625
    my($pkg_ver) = $chg_hashref->{'Version'};
626
 
627
    my($guess_section) = Guess_Section($chg_hashref);
628
    my($pkg_dir) = join('/',
629
        ($pool_dir, PoolDir($pkg_name, $guess_section), $pkg_name));
630
 
631
    # Make sure the package directory exists (and is a directory!)
632
 
633
    if (! -e $pkg_dir) {
634
        if (!mkdir($pkg_dir)) {
635
            $Error = "Failed to mkdir '$pkg_dir': $!";
636
            return 0;
637
        }
638
        if (!chmod($Options{'pool_dir_mode'}, $pkg_dir)) {
639
            $Error = "Failed to chmod '$pkg_dir': $!";
640
            return 0;
641
        }
642
    } elsif (! -d $pkg_dir) {
643
        $Error = "Target '$pkg_dir' is not a directory.";
644
        return 0;
645
    }
646
 
647
    # Walk the File Hash, trying to install each listed file into the
648
    # pool directory.
649
 
650
    my($filehash);
651
 
652
    foreach $filehash (@{$chg_hashref->{'Files'}}) {
653
        my($file) = $filehash->{'Filename'};
654
        if (!Move_File("${incoming_dir}/${file}", "${pkg_dir}/${file}",
655
                $Options{'pool_file_mode'})) {
656
            $Error = "Failed to move '${incoming_dir}/${file}' ";
657
            $Error .= "to '${pkg_dir}/${file}': ${DebPool::Util::Error}";
658
            return 0;
659
        }
660
    }
661
 
662
    # Generate and install .package and .source metadata files.
663
 
664
    my($pkg_file) = Generate_Package($chg_hashref);
665
 
666
    if (!defined($pkg_file)) {
667
        $Error = "Failed to generate .package file: $Error";
668
        return undef;
669
    }
670
 
671
    my($target) = "$pkg_dir/${pkg_name}_" . Strip_Epoch($pkg_ver) . '.package';
672
 
673
    if (!Move_File($pkg_file, $target, $Options{'pool_file_mode'})) {
674
        $Error = "Failed to move '$pkg_file' to '$target': ";
675
        $Error .= $DebPool::Util::Error;
676
        return 0;
677
    }
678
 
679
    if (defined($dsc) && defined($dsc_hashref)) {
680
        my($src_file) = Generate_Source($dsc, $dsc_hashref, $chg_hashref);
681
 
682
        if (!defined($src_file)) {
683
            $Error = "Failed to generate .source file: $Error";
684
            return undef;
685
        }
686
 
687
        $target = "$pkg_dir/${pkg_name}_" . Strip_Epoch($pkg_ver) . '.source';
688
 
689
        if (!Move_File($src_file, $target, $Options{'pool_file_mode'})) {
690
            $Error = "Failed to move '$src_file' to '$target': ";
691
            $Error .= $DebPool::Util::Error;
692
            return 0;
693
        }
694
    }
695
 
696
    # Finally, try to install the changes file to the installed directory.
697
 
698
    if (!Move_File("$incoming_dir/$changes", "$installed_dir/$changes",
699
            $Options{'installed_file_mode'})) {
700
        $Error = "Failed to move '$incoming_dir/$changes' to ";
701
        $Error .= "'$installed_dir/$changes': ${DebPool::Util::Error}";
702
        return 0;
703
    }
704
 
705
    # Update the various databases.
706
 
707
    my($distribution);
708
 
709
    # This whole block is just to calculate the component. What a stupid
710
    # setup - it should be in the changes file. Oh well.
711
 
712
    my(@filearray) = @{$chg_hashref->{'Files'}};
713
    my($fileref) = $filearray[0];
714
    my($section) = $fileref->{'Section'};
715
    my($component) = Strip_Subsection($section);
716
 
717
    foreach $distribution (@{$distributions}) {
718
        Set_Versions($distribution, $pkg_name, $pkg_ver,
719
            $chg_hashref->{'Files'});
720
        $ComponentDB{$distribution}->{$pkg_name} = $component;
721
    }
722
 
723
    return 1;
724
}
725
 
726
# Reject_Package($changes, $chg_hashref)
727
#
728
# Move all of the package files for $chg_hashref (which should be a
729
# Parse_Changes result hash) into the rejected directory, as well as the
730
# file in $changes. Returns 1 if successful, 0 if not (and sets $Error).
731
 
732
sub Reject_Package {
733
    use DebPool::Config qw(:vars);
734
    use DebPool::DB qw(:functions);
735
    use DebPool::Util qw(:functions);
736
 
737
    my($changes, $chg_hashref) = @_;
738
 
739
    my($incoming_dir) = $Options{'incoming_dir'};
740
    my($reject_dir) = $Options{'reject_dir'};
741
    my($reject_file_mode) = $Options{'reject_file_mode'};
742
 
743
    # Walk the File Hash, moving each file to the rejected directory.
744
 
745
    my($filehash);
746
 
747
    foreach $filehash (@{$chg_hashref->{'Files'}}) {
748
        my($file) = $filehash->{'Filename'};
749
        if (!Move_File("$incoming_dir/$file", "$reject_dir/$file",
750
                $reject_file_mode)) {
751
            $Error = "Failed to move '$incoming_dir/$file' ";
752
            $Error .= "to '$reject_dir/$file': ${DebPool::Util::Error}";
753
            return 0;
754
        }
755
    }
756
 
757
    # Now move the changes file to the rejected directory, as well.
758
 
759
    if (!Move_File("$incoming_dir/$changes", "$reject_dir/$changes",
760
            $reject_file_mode)) {
761
        $Error = "Failed to move '$incoming_dir/$changes' to ";
762
        $Error .= "'$reject_dir/$changes': ${DebPool::Util::Error}";
763
        return 0;
764
    }
765
 
766
    return 1;
767
}
768
 
769
# Verify_MD5($file, $md5)
770
#
771
# Verifies the MD5 checksum of $file against $md5. Returns 1 if it matches,
772
# 0 if it doesn't, and undef (also setting $Error) if an error occurs. This
773
# routine uses the dpkg md5sum utility, to avoid pulling in a dependancy on
774
# Digest::MD5.
775
 
776
sub Verify_MD5 {
777
    use DebPool::Logging qw(:functions :facility :level);
778
 
779
    my($file, $md5) = @_;
780
 
781
    # Read in and mangle the md5 output.
782
 
783
    if (! -r $file) { # The file doesn't exist! Will be hard to checksum it...
784
        my($msg) = "MD5 checksum unavailable: file '$file' does not exist!";
785
        Log_Message($msg, LOG_GENERAL, LOG_ERROR);
786
        return 0;
787
    }
788
 
789
    my($cmd_result) = `/usr/bin/md5sum $file`;
790
    if (!$cmd_result) { # Failed to run md5sum for some reason
791
        my($msg) = "MD5 checksum unavailable: file '$file'";
792
        Log_Message($msg, LOG_GENERAL, LOG_ERROR);
793
        return 0;
794
    }
795
 
796
    $cmd_result =~ m/^([[:xdigit:]]+)\s+/;
797
    my($check_md5) = $1;
798
 
799
    if ($md5 ne $check_md5) {
800
        my($msg) = "MD5 checksum failure: file '$file', ";
801
        $msg .= "expected '$md5', got '$check_md5'";
802
        Log_Message($msg, LOG_GENERAL, LOG_ERROR);
803
        return 0;
804
    }
805
 
806
    return 1;
807
}
808
 
809
# Audit_Package($package, $chg_hashref)
810
#
811
# Delete a package and changes files for the named (source) package which
812
# are not referenced by any version currently found in the various release
813
# databases. Returns the number of files unlinked (which may be 0), or
814
# undef (and sets $Error) on an error.
815
 
816
sub Audit_Package {
817
    use DebPool::Config qw(:vars);
818
    use DebPool::Dirs qw(:functions);
819
    use DebPool::Logging qw(:functions :facility :level);
820
 
821
    my($package, $changes_hashref) = @_;
822
 
823
    my($installed_dir) = $Options{'installed_dir'};
824
    my($pool_dir) = $Options{'pool_dir'};
825
 
826
    my($section) = Guess_Section($changes_hashref);
827
    my($package_dir) = join('/',
828
        ($pool_dir, PoolDir($package, $section), $package));
829
 
830
    my(@changes) = grep(/${package}_/, Scan_Changes($installed_dir));
831
 
832
    my($pool_scan) = Scan_All($package_dir);
833
    if (!defined($pool_scan)) {
834
        $Error = $DebPool::Dirs::Error;
835
        return undef;
836
    }
837
    my(@pool_files) = @{$pool_scan};
838
 
839
    # Go through each file found in the pool directory, and determine its
840
    # version. If it isn't in the current version tables, unlink it.
841
 
842
    my($file);
843
    my($unlinked) = 0;
844
    foreach $file (@pool_files) {
845
        my($orig) = 0;
846
        my($deb) = 0;
847
        my($src) = 0;
848
        my($bin_package, $version);
849
 
850
        if ($file =~ m/^([^_]+)_([^_]+)\.orig\.tar\.gz$/) { # orig.tar.gz
851
            $bin_package = $1;
852
            $version = $2;
853
            $src = 1;
854
            $orig = 1;
855
        } elsif ($file =~ m/^([^_]+)_([^_]+)\.tar\.gz$/) { # tar.gz
856
            $bin_package = $1;
857
            $version = $2;
858
            $src = 1;
859
        } elsif ($file =~ m/^([^_]+)_([^_]+)\.diff\.gz$/) { # diff.gz
860
            $bin_package = $1;
861
            $version = $2;
862
            $src = 1;
863
        } elsif ($file =~ m/^([^_]+)_([^_]+)\.dsc$/) { # dsc
864
            $bin_package = $1;
865
            $version = $2;
866
            $src = 1;
867
        } elsif ($file =~ m/^([^_]+)_([^_]+)_.+\.deb$/) { # deb
868
            $bin_package = $1;
869
            $version = $2;
870
            $deb = 1;
871
        } elsif ($file =~ m/^([^_]+)_([^_]+)_.+\.udeb$/) { # udeb
872
            $bin_package = $1;
873
            $version = $2;
874
            $deb = 1;
875
        } elsif ($file =~ m/^([^_]+)_([^_]+)\.package$/) { # package metadata
876
            $bin_package = $1;
877
            $version = $2;
878
        } elsif ($file =~ m/^([^_]+)_([^_]+)\.source$/) { # source metadata
879
            $bin_package = $1;
880
            $version = $2;
881
        } else {
882
            Log_Message("Couldn't figure out filetype for '$package_dir/$file'",
883
                LOG_AUDIT, LOG_ERROR);
884
            next;
885
        }
886
 
887
        # Skip it if we recognize it as a valid version.
888
 
889
        my($matched) = 0;
890
        my($dist);
891
        foreach $dist (@{$Options{'realdists'}}) {
892
            my($ver_pkg);
893
            if ($src) {
894
                $ver_pkg = 'source';
895
            } elsif ($deb) {
896
                $ver_pkg = $bin_package;
897
            } else {
898
                $ver_pkg = 'meta';
899
            }
900
 
901
            my($dist_ver) = Get_Version($dist, $package, $ver_pkg);
902
            next if (!defined($dist_ver)); # No version in specified dist
903
            $dist_ver = Strip_Epoch($dist_ver);
904
            if ($orig) { $dist_ver =~ s/-.+$//; }
905
            if ($version eq $dist_ver) { $matched = 1; }
906
        }
907
        next if $matched;
908
 
909
        # Otherwise, unlink it.
910
 
911
        if (unlink("$package_dir/$file")) {
912
            $unlinked += 1;
913
            Log_Message("Unlinked obsolete pool file '$package_dir/$file'",
914
                LOG_AUDIT, LOG_DEBUG);
915
        } else {
916
            Log_Message("Couldn't obsolete pool file '$package_dir/$file'",
917
                LOG_AUDIT, LOG_ERROR);
918
        }
919
    }
920
 
921
    foreach $file (@changes) {
922
        $file =~ m/^[^_]+_([^_]+)_.+$/; # changes
923
        my($version) = $1;
924
 
925
        my($matched) = 0;
926
        my($dist);
927
        foreach $dist (@{$Options{'realdists'}}) {
928
            my($dist_ver) = Get_Version($dist, $package, 'meta');
929
            next if (!defined($dist_ver)); # No version in specified dist
930
            $dist_ver = Strip_Epoch($dist_ver);
931
            if ($version eq $dist_ver) { $matched = 1; }
932
        }
933
        next if $matched;
934
 
935
        if (unlink("$installed_dir/$file")) {
936
            $unlinked += 1;
937
            Log_Message("Unlinked obsolete changes file " .
938
                "'$installed_dir/$file'", LOG_AUDIT, LOG_DEBUG);
939
        } else {
940
            Log_Message("Couldn't obsolete changes file " .
941
                "'$installed_dir/$file'", LOG_AUDIT, LOG_ERROR);
942
        }
943
    }
944
 
945
    return $unlinked;
946
}
947
 
948
# Generate_Package($chg_hashref)
949
#
950
# Generates a .package metadata file (Packages entries for each binary
951
# package) in the tempfile area, and returns the filename. Returns undef
952
# (and sets $Error) on failure.
953
 
954
sub Generate_Package {
955
    use DebPool::Config qw(:vars);
956
    use DebPool::Dirs qw(:functions);
957
    use DebPool::Logging qw(:functions :facility :level);
958
 
959
    my($changes_data) = @_;
960
    my($source) = $changes_data->{'Source'};
961
    my(@files) = @{$changes_data->{'Files'}};
962
    my($pool_base) = PoolBasePath();
963
 
964
    # Grab a temporary file.
965
 
966
    my($tmpfile_handle, $tmpfile_name) = tempfile();
967
 
968
    my(@packages) = @{$changes_data->{'Binary'}};
969
    my(@architectures) = @{$changes_data->{'Architecture'}};
970
    @architectures = grep(!/source/, @architectures); # Source is on it's own.
971
 
972
    my($package, $arch);
973
 
974
    foreach $package (@packages) {
975
        foreach $arch (@architectures) {
976
            # Construct a pattern to match the filename and nothing else.
977
            # This used to be an exact match using the source version, but
978
            # Debian's standards are sort of insane, and the version number
979
            # on binary files is not always the same as that on the source
980
            # file (nor is it even something simple like "source version
981
            # without the epoch" -- it is more or less arbitrary, as long
982
            # as it is a well-formed version number).
983
 
984
            my($filepat) = "${package}_.*_${arch}\\.deb";
985
            $filepat =~ s/\+/\\\+/;
986
 
987
            my($section) = Guess_Section($changes_data);
988
            my($pool) = join('/', (PoolDir($source, $section), $source));
989
 
990
            my($marker) = -1;
991
            my($count) = 0;
992
 
993
            # Step through each file, match against filename. Save matches
994
            # for later use.
995
 
996
            for $count (0..$#files) {
997
                if ($files[$count]->{'Filename'} =~ m/$filepat/) {
998
                    $marker = $count;
999
                }
1000
            }
1001
 
1002
            # The changes file has a stupid quirk; it puts all binaries from
1003
            # a package in the Binary: line, even if they weren't built (for
1004
            # example, an Arch: all doc package when doing an arch-only build
1005
            # for a port). So if we didn't find a .deb file for it, assume
1006
            # that it's one of those, and skip, rather than choking on it.
1007
 
1008
            next if (-1 == $marker);
1009
 
1010
            # Run Dpkg_Info to grab the dpkg --info data on the package.
1011
 
1012
            my($file) = $files[$marker]->{'Filename'};
1013
            my($info) = Dpkg_Info("$Options{'pool_dir'}/$pool/$file");
1014
 
1015
            # Dump all of our data into the metadata tempfile.
1016
 
1017
            print $tmpfile_handle "Package: $package\n";
1018
 
1019
            if (defined($info->{'Priority'})) {
1020
                print $tmpfile_handle "Priority: $info->{'Priority'}\n";
1021
            }
1022
 
1023
            if (defined($info->{'Section'})) {
1024
                print $tmpfile_handle "Section: $info->{'Section'}\n";
1025
            }
1026
 
1027
            if (defined($info->{'Essential'})) {
1028
                print $tmpfile_handle "Essential: $info->{'Essential'}\n";
1029
            }
1030
 
1031
            print $tmpfile_handle "Installed-Size: $info->{'Installed-Size'}\n";
1032
 
1033
            print $tmpfile_handle "Maintainer: $changes_data->{'Maintainer'}\n";
1034
            print $tmpfile_handle "Architecture: $arch\n";
1035
            print $tmpfile_handle "Source: $source\n";
1036
            print $tmpfile_handle "Version: $changes_data->{'Version'}\n";
1037
 
1038
            # All of the inter-package relationships go together, and any
1039
            # one of them can potentially be empty (and omitted).
1040
 
1041
            my($field);
1042
            foreach $field (@Relationship_Fields) {
1043
                if (defined($info->{$field})) {
1044
                    print $tmpfile_handle "${field}: $info->{$field}\n";
1045
                }
1046
            }
1047
 
1048
            # And now, some stuff we can grab out of the parsed changes
1049
            # data far more easily than anywhere else.
1050
 
1051
            print $tmpfile_handle "Filename: $pool_base/$pool/$file\n";
1052
 
1053
            print $tmpfile_handle "Size: $files[$marker]->{'Size'}\n";
1054
            print $tmpfile_handle "MD5sum: $files[$marker]->{'MD5Sum'}\n";
1055
 
1056
            print $tmpfile_handle "Description: $info->{'Description'}";
1057
        }
1058
 
1059
        print $tmpfile_handle "\n";
1060
    }
1061
 
1062
    # All done
1063
 
1064
    close($tmpfile_handle);
1065
    return $tmpfile_name;
1066
}
1067
 
1068
# Generate_Source($dsc, $dsc_hashref, $changes_hashref)
1069
#
1070
# Generates a .source metadata file (Sources entries for the source
1071
# package) in the tempfile area, and returns the filename. Returns undef
1072
# (and sets $Error) on failure.
1073
 
1074
sub Generate_Source {
1075
    use DebPool::Dirs qw(:functions);
1076
    use DebPool::Logging qw(:functions :facility :level);
1077
 
1078
    my($dsc, $dsc_data, $changes_data) = @_;
1079
    my($source) = $dsc_data->{'Source'};
1080
    my(@files) = @{$dsc_data->{'Files'}};
1081
 
1082
    # Figure out the priority and section, using the DSC filename and
1083
    # the Changes file data.
1084
 
1085
    my($section, $priority);
1086
    my($filehr);
1087
    foreach $filehr (@{$changes_data->{'Files'}}) {
1088
        if ($filehr->{'Filename'} eq $dsc) {
1089
            $section = $filehr->{'Section'};
1090
            $priority = $filehr->{'Priority'};
1091
        }
1092
    }
1093
 
1094
    # Grab a temporary file.
1095
 
1096
    my($tmpfile_handle, $tmpfile_name) = tempfile();
1097
 
1098
    # Dump out various metadata.
1099
 
1100
    print $tmpfile_handle "Package: $source\n";
1101
    print $tmpfile_handle "Binary: " . join(', ', @{$dsc_data->{'Binary'}}) . "\n";
1102
    print $tmpfile_handle "Version: $dsc_data->{'Version'}\n";
1103
    print $tmpfile_handle "Priority: $priority\n";
1104
    print $tmpfile_handle "Section: $section\n";
1105
    print $tmpfile_handle "Maintainer: $dsc_data->{'Maintainer'}\n";
1106
 
1107
    if (defined($dsc_data->{'Build-Depends'})) {
1108
        print $tmpfile_handle 'Build-Depends: ';
1109
        print $tmpfile_handle join(', ', @{$dsc_data->{'Build-Depends'}}) . "\n";
1110
    }
1111
 
1112
    if (defined($dsc_data->{'Build-Depends-Indep'})) {
1113
        print $tmpfile_handle 'Build-Depends-Indep: ';
1114
        print $tmpfile_handle join(', ', @{$dsc_data->{'Build-Depends-Indep'}}) . "\n";
1115
    }
1116
 
1117
    print $tmpfile_handle 'Architecture: ';
1118
    print $tmpfile_handle join(' ', @{$dsc_data->{'Architecture'}}) . "\n";
1119
 
1120
    print $tmpfile_handle "Standards-Version: $dsc_data->{'Standards-Version'}\n";
1121
    print $tmpfile_handle "Format: $dsc_data->{'Format'}\n";
1122
    print $tmpfile_handle "Directory: " .  join('/',
1123
        (PoolBasePath(), PoolDir($source, $section), $source)) . "\n";
1124
 
1125
    print $tmpfile_handle "Files:\n";
1126
 
1127
    my($fileref);
1128
    foreach $fileref (@files) {
1129
        print $tmpfile_handle " $fileref->{'MD5Sum'}";
1130
        print $tmpfile_handle " $fileref->{'Size'}";
1131
        print $tmpfile_handle " $fileref->{'Filename'}\n";
1132
    }
1133
 
1134
    print $tmpfile_handle "\n";
1135
 
1136
    # All done
1137
 
1138
    close($tmpfile_handle);
1139
    return $tmpfile_name;
1140
}
1141
 
1142
# Dpkg_Info($file)
1143
#
1144
# Runs dpkg --info on $file, and returns a hash of relevant information.
1145
#
1146
# Internal support function for Generate_Package.
1147
 
1148
sub Dpkg_Info {
1149
    my($file) = @_;
1150
    my(%result);
1151
 
1152
    # Grab the info from dpkg --info.
1153
 
1154
    my(@info) = `/usr/bin/dpkg --info $file`;
1155
    my($smashed) = join('', @info);
1156
 
1157
    # Look for each of these fields in the info. All are single line values,
1158
    # so the matching is fairly easy.
1159
 
1160
    my($field);
1161
 
1162
    foreach $field (@Info_Fields, @Relationship_Fields) {
1163
        if ($smashed =~ m/\n ${field}:\s+(\S.*)\n/) {
1164
            $result{$field} = $1;
1165
        }
1166
    }
1167
 
1168
    # And, finally, grab the description.
1169
 
1170
    my($line);
1171
    my($found) = 0;
1172
    foreach $line (@info) {
1173
        if ($found) {
1174
            $line =~ s/^ //;
1175
            $result{'Description'} .= $line;
1176
        } elsif ($line =~ m/^ Description: (.+)/) {
1177
            $result{'Description'} = "$1\n";
1178
            $found = 1;
1179
        }
1180
    }
1181
 
1182
    return \%result;
1183
}
1184
 
1185
# Install_List($archive, $component, $architecture, $listfile, $gzfile)
1186
#
1187
# Installs a distribution list file (from Generate_List), along with an
1188
# optional gzipped version of the same file (if $gzfile is defined).
1189
# Returns 1 on success, or 0 (and sets $Error) on failure.
1190
 
1191
sub Install_List {
1192
    use DebPool::Config qw(:vars);
1193
    use DebPool::Dirs qw(:functions);
1194
 
1195
    my($archive, $component, $architecture, $listfile, $gzfile) = @_;
1196
 
1197
    my($dists_file_mode) = $Options{'dists_file_mode'};
1198
    my($inst_file) = "$Options{'dists_dir'}/";
1199
    $inst_file .= Archfile($archive, $component, $architecture, 0);
1200
 
1201
    # Now install the file(s) into the appropriate place(s).
1202
 
1203
    if (!Move_File($listfile, $inst_file, $dists_file_mode)) {
1204
        $Error = "Couldn't install distribution file '$listfile' ";
1205
        $Error .= "to '${inst_file}': ${DebPool::Util::Error}";
1206
        return 0;
1207
    }
1208
 
1209
    if (defined($gzfile) && !Move_File($gzfile, "${inst_file}.gz",
1210
            $dists_file_mode)) {
1211
        $Error = "Couldn't install gzipped distribution file '$gzfile' ";
1212
        $Error .= "to '${inst_file}.gz': ${DebPool::Util::Error}";
1213
        return 0;
1214
    }
1215
 
1216
    return 1;
1217
}
1218
 
1219
# Guess_Section($changes_hashref)
1220
#
1221
# Attempt to guess the freeness section of a package based on the data
1222
# for the first file listed in the changes.
1223
 
1224
sub Guess_Section {
1225
    # Pull out the primary section from the changes data. Note that this is
1226
    # a cheap hack, but it is mostly used when needing the pool directory
1227
    # section, which is based solely on freeness-sections (main, contrib,
1228
    # non-free).
1229
 
1230
    my($changes_hashref) = @_;
1231
 
1232
    my(@changes_files) = @{$changes_hashref->{'Files'}};
1233
    return $changes_files[0]->{'Section'};
1234
}
1235
 
1236
# Strip_Epoch($version)
1237
#
1238
# Strips any epoch data off of the version.
1239
 
1240
sub Strip_Epoch {
1241
    my($version) = @_;
1242
 
1243
    $version =~ s/^[^:]://;
1244
    return $version;
1245
}
1246
 
1247
END {}
1248
 
1249
1;
1250
 
1251
__END__
1252
 
1253
# vim:set tabstop=4 expandtab: