WebSVN - Blame - Rev 1 - /branches/magnus/trunk/share/DebPool/Packages.pm

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:

Subversion Repositories

(root)/branches/magnus/trunk/share/DebPool/Packages.pm @ 3 - Rev 1