Rev 1 | Rev 9 | Go to most recent revision | 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: |